*Deck DBDSQR
      SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
     $                   LDU, C, LDC, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
C     ..
C     .. Array Arguments ..
      Real*8   C( LDC, * ), D( * ), E( * ), U( LDU, * ),
     $                   VT( LDVT, * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DBDSQR computes the singular value decomposition (SVD) of a real
C  N-by-N (upper or lower) bidiagonal matrix B:  B = Q * S * P' (P'
C  denotes the transpose of P), where S is a diagonal matrix with
C  non-negative diagonal elements (the singular values of B), and Q
C  and P are orthogonal matrices.
C
C  The routine computes S, and optionally computes U * Q, P' * VT,
C  or Q' * C, for given real input matrices U, VT, and C.
C
C  See "Computing  Small Singular Values of Bidiagonal Matrices With
C  Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
C  LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
C  no. 5, pp. 873-912, Sept 1990) and
C  "Accurate singular values and differential qd algorithms," by
C  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
C  Department, University of California at Berkeley, July 1992
C  for a detailed description of the algorithm.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          = 'U':  B is upper bidiagonal;
C          = 'L':  B is lower bidiagonal.
C
C  N       (input) INTEGER
C          The order of the matrix B.  N >= 0.
C
C  NCVT    (input) INTEGER
C          The number of columns of the matrix VT. NCVT >= 0.
C
C  NRU     (input) INTEGER
C          The number of rows of the matrix U. NRU >= 0.
C
C  NCC     (input) INTEGER
C          The number of columns of the matrix C. NCC >= 0.
C
C  D       (input/output) Real*8 array, dimension (N)
C          On entry, the n diagonal elements of the bidiagonal matrix B.
C          On exit, if INFO=0, the singular values of B in decreasing
C          order.
C
C  E       (input/output) Real*8 array, dimension (N)
C          On entry, the elements of E contain the
C          offdiagonal elements of the bidiagonal matrix whose SVD
C          is desired. On normal exit (INFO = 0), E is destroyed.
C          If the algorithm does not converge (INFO > 0), D and E
C          will contain the diagonal and superdiagonal elements of a
C          bidiagonal matrix orthogonally equivalent to the one given
C          as input. E(N) is used for workspace.
C
C  VT      (input/output) Real*8 array, dimension (LDVT, NCVT)
C          On entry, an N-by-NCVT matrix VT.
C          On exit, VT is overwritten by P' * VT.
C          VT is not referenced if NCVT = 0.
C
C  LDVT    (input) INTEGER
C          The leading dimension of the array VT.
C          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
C
C  U       (input/output) Real*8 array, dimension (LDU, N)
C          On entry, an NRU-by-N matrix U.
C          On exit, U is overwritten by U * Q.
C          U is not referenced if NRU = 0.
C
C  LDU     (input) INTEGER
C          The leading dimension of the array U.  LDU >= max(1,NRU).
C
C  C       (input/output) Real*8 array, dimension (LDC, NCC)
C          On entry, an N-by-NCC matrix C.
C          On exit, C is overwritten by Q' * C.
C          C is not referenced if NCC = 0.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C.
C          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
C
C  WORK    (workspace) Real*8 array, dimension
C            2*N  if only singular values wanted (NCVT = NRU = NCC = 0)
C            max( 1, 4*N-4 ) otherwise
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  If INFO = -i, the i-th argument had an illegal value
C          > 0:  the algorithm did not converge; D and E contain the
C                elements of a bidiagonal matrix which is orthogonally
C                similar to the input matrix B;  if INFO = i, i
C                elements of E have not converged to zero.
C
C  Internal Parameters
C  ===================
C
C  TOLMUL  Real*8, default = max(10,min(100,EPS**(-1/8)))
C          TOLMUL controls the convergence criterion of the QR loop.
C          If it is positive, TOLMUL*EPS is the desired relative
C             precision in the computed singular values.
C          If it is negative, abs(TOLMUL*EPS*sigma_max) is the
C             desired absolute accuracy in the computed singular
C             values (corresponds to relative accuracy
C             abs(TOLMUL*EPS) in the largest singular value.
C          abs(TOLMUL) should be between 1 and 1/EPS, and preferably
C             between 10 (for fast convergence) and .1/EPS
C             (for there to be some accuracy in the results).
C          Default is to lose at either one eighth or 2 of the
C             available decimal digits in each computed singular value
C             (whichever is smaller).
C
C  MAXITR  INTEGER, default = 6
C          MAXITR controls the maximum number of passes of the
C          algorithm through its inner loop. The algorithms stops
C          (and so fails to converge) if the number of passes
C          through the inner loop exceeds MAXITR*N**2.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D0 )
      Real*8   NEGONE
      PARAMETER          ( NEGONE = -1.0D0 )
      Real*8   HNDRTH
      PARAMETER          ( HNDRTH = 0.01D0 )
      Real*8   TEN
      PARAMETER          ( TEN = 10.0D0 )
      Real*8   HNDRD
      PARAMETER          ( HNDRD = 100.0D0 )
      Real*8   MEIGTH
      PARAMETER          ( MEIGTH = -0.125D0 )
      INTEGER            MAXITR
      PARAMETER          ( MAXITR = 6 )
C     ..
C     .. Local Scalars ..
      LOGICAL            ROTATE
      INTEGER            I, IDIR, IROT, ISUB, ITER, IUPLO, J, LL, LLL,
     $                   M, MAXIT, NM1, NM12, NM13, OLDLL, OLDM
      Real*8   ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
     $                   OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
     $                   SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
     $                   SN, THRESH, TOL, TOLMUL, UNFL
      LOGICAL            GLSame
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C     Test the input parameters.
C
      INFO = 0
      IUPLO = 0
      IF( GLSame( UPLO, 'U' ) )
     $   IUPLO = 1
      IF( GLSame( UPLO, 'L' ) )
     $   IUPLO = 2
      IF( IUPLO.EQ.0 ) 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) Call GLBErr('DBDSQR',Info)
      If(N.eq.0) RETURN
      If(N.eq.1) GOTO 150
C
C     ROTATE is true if any singular vectors desired, false otherwise
C
      ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
C
C     If no singular vectors desired, use qd algorithm
C
      IF( .NOT.ROTATE ) THEN
         CALL DLASQ1( N, D, E, WORK, INFO )
         RETURN
      END IF
C
      NM1 = N - 1
      NM12 = NM1 + NM1
      NM13 = NM12 + NM1
C
C     Get machine constants
C
      UNFL = SFMin
C
C     If matrix lower bidiagonal, rotate to be upper bidiagonal
C     by applying Givens rotations on the left
C
      IF( IUPLO.EQ.2 ) 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 )
            WORK( I ) = CS
            WORK( NM1+I ) = SN
   10    CONTINUE
C
C        Update singular vectors if desired
C
         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
C
C     Compute singular values to relative accuracy TOL
C     (By setting TOL to be negative, algorithm will compute
C     singular values to absolute accuracy ABS(TOL)*norm(input matrix))
C
      TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
      TOL = TOLMUL*EPS
C
C     Compute approximate maximum, minimum singular values
C
      SMAX = ABS( D( N ) )
      DO 20 I = 1, N - 1
         SMAX = MAX( SMAX, ABS( D( I ) ), ABS( E( I ) ) )
   20 CONTINUE
      SMINL = ZERO
      IF( TOL.GE.ZERO ) THEN
C
C        Relative accuracy desired
C
         SMINOA = ABS( D( 1 ) )
         IF( SMINOA.EQ.ZERO )
     $      GO TO 40
         MU = SMINOA
         DO 30 I = 2, N
            MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
            SMINOA = MIN( SMINOA, MU )
            IF( SMINOA.EQ.ZERO )
     $         GO TO 40
   30    CONTINUE
   40    CONTINUE
         SMINOA = SMINOA / SQRT( GFloat( N ) )
         THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
      ELSE
C
C        Absolute accuracy desired
C
         THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
      END IF
C
C     Prepare for main iteration loop for the singular values
C     (MAXIT is the maximum number of passes through the inner
C     loop permitted before nonconvergence signalled.)
C
      MAXIT = MAXITR*N*N
      ITER = 0
      OLDLL = -1
      OLDM = -1
C
C     M points to last element of unconverged part of matrix
C
      M = N
C
C     Begin main iteration loop
C
   50 CONTINUE
C
C     Check for convergence or exceeding iteration count
C
      IF( M.LE.1 )
     $   GO TO 150
      IF( ITER.GT.MAXIT )
     $   GO TO 190
C
C     Find diagonal block of matrix to work on
C
      IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
     $   D( M ) = ZERO
      SMAX = ABS( D( M ) )
      SMIN = SMAX
      DO 60 LLL = 1, M
         LL = M - LLL
         IF( LL.EQ.0 )
     $      GO TO 80
         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 70
         SMIN = MIN( SMIN, ABSS )
         SMAX = MAX( SMAX, ABSS, ABSE )
   60 CONTINUE
   70 CONTINUE
      E( LL ) = ZERO
C
C     Matrix splits since E(LL) = 0
C
      IF( LL.EQ.M-1 ) THEN
C
C        Convergence of bottom singular value, return to top of loop
C
         M = M - 1
         GO TO 50
      END IF
   80 CONTINUE
      LL = LL + 1
C
C     E(LL) through E(M-1) are nonzero, E(LL-1) is zero
C
      IF( LL.EQ.M-1 ) THEN
C
C        2 by 2 block, handle separately
C
         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
C
C        Compute singular vectors, if desired
C
         IF( NCVT.GT.0 )
     $      CALL GRot( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR,
     $                 SINR )
         IF( NRU.GT.0 )
     $      CALL GRot( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
         IF( NCC.GT.0 )
     $      CALL GRot( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
     $                 SINL )
         M = M - 2
         GO TO 50
      END IF
C
C     If working on new submatrix, choose shift direction
C     (from larger end diagonal element towards smaller)
C
      IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
         IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
C
C           Chase bulge from top (big end) to bottom (small end)
C
            IDIR = 1
         ELSE
C
C           Chase bulge from bottom (big end) to top (small end)
C
            IDIR = 2
         END IF
      END IF
C
C     Apply convergence tests
C
      IF( IDIR.EQ.1 ) THEN
C
C        Run convergence test in forward direction
C        First apply standard test to bottom of matrix
C
         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 50
         END IF
C
         IF( TOL.GE.ZERO ) THEN
C
C           If relative accuracy desired,
C           apply convergence criterion forward
C
            MU = ABS( D( LL ) )
            SMINL = MU
            DO 90 LLL = LL, M - 1
               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
                  E( LLL ) = ZERO
                  GO TO 50
               END IF
               MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
               SMINL = MIN( SMINL, MU )
   90       CONTINUE
         END IF
C
      ELSE
C
C        Run convergence test in backward direction
C        First apply standard test to top of matrix
C
         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 50
         END IF
C
         IF( TOL.GE.ZERO ) THEN
C
C           If relative accuracy desired,
C           apply convergence criterion backward
C
            MU = ABS( D( M ) )
            SMINL = MU
            DO 100 LLL = M - 1, LL, -1
               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
                  E( LLL ) = ZERO
                  GO TO 50
               END IF
               MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
               SMINL = MIN( SMINL, MU )
  100       CONTINUE
         END IF
      END IF
      OLDLL = LL
      OLDM = M
C
C     Compute shift.  First, test if shifting would ruin relative
C     accuracy, and if so set the shift to zero.
C
      IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
     $    MAX( EPS, HNDRTH*TOL ) ) THEN
C
C        Use a zero shift to avoid loss of relative accuracy
C
         SHIFT = ZERO
      ELSE
C
C        Compute the shift from 2-by-2 block at end of matrix
C
         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
C
C        Test if shift negligible, and if so set to zero
C
         IF( SLL.GT.ZERO ) THEN
            IF( ( SHIFT / SLL )**2.LT.EPS )
     $         SHIFT = ZERO
         END IF
      END IF
C
C     Increment iteration count
C
      ITER = ITER + M - LL
C
C     If SHIFT = 0, do simplified QR iteration
C
      IF( SHIFT.EQ.ZERO ) THEN
         IF( IDIR.EQ.1 ) THEN
C
C           Chase bulge from top to bottom
C           Save cosines and sines for later singular vector updates
C
            CS = ONE
            OLDCS = ONE
            CALL DLARTG( D( LL )*CS, E( LL ), CS, SN, R )
            CALL DLARTG( OLDCS*R, D( LL+1 )*SN, OLDCS, OLDSN, D( LL ) )
            WORK( 1 ) = CS
            WORK( 1+NM1 ) = SN
            WORK( 1+NM12 ) = OLDCS
            WORK( 1+NM13 ) = OLDSN
            IROT = 1
            DO 110 I = LL + 1, M - 1
               CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
               E( I-1 ) = OLDSN*R
               CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
               IROT = IROT + 1
               WORK( IROT ) = CS
               WORK( IROT+NM1 ) = SN
               WORK( IROT+NM12 ) = OLDCS
               WORK( IROT+NM13 ) = OLDSN
  110       CONTINUE
            H = D( M )*CS
            D( M ) = H*OLDCS
            E( M-1 ) = H*OLDSN
C
C           Update singular vectors
C
            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 )
C
C           Test convergence
C
            IF( ABS( E( M-1 ) ).LE.THRESH )
     $         E( M-1 ) = ZERO
C
         ELSE
C
C           Chase bulge from bottom to top
C           Save cosines and sines for later singular vector updates
C
            CS = ONE
            OLDCS = ONE
            CALL DLARTG( D( M )*CS, E( M-1 ), CS, SN, R )
            CALL DLARTG( OLDCS*R, D( M-1 )*SN, OLDCS, OLDSN, D( M ) )
            WORK( M-LL ) = CS
            WORK( M-LL+NM1 ) = -SN
            WORK( M-LL+NM12 ) = OLDCS
            WORK( M-LL+NM13 ) = -OLDSN
            IROT = M - LL
            DO 120 I = M - 1, LL + 1, -1
               CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
               E( I ) = OLDSN*R
               CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
               IROT = IROT - 1
               WORK( IROT ) = CS
               WORK( IROT+NM1 ) = -SN
               WORK( IROT+NM12 ) = OLDCS
               WORK( IROT+NM13 ) = -OLDSN
  120       CONTINUE
            H = D( LL )*CS
            D( LL ) = H*OLDCS
            E( LL ) = H*OLDSN
C
C           Update singular vectors
C
            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 )
C
C           Test convergence
C
            IF( ABS( E( LL ) ).LE.THRESH )
     $         E( LL ) = ZERO
         END IF
      ELSE
C
C        Use nonzero shift
C
         IF( IDIR.EQ.1 ) THEN
C
C           Chase bulge from top to bottom
C           Save cosines and sines for later singular vector updates
C
            F = ( ABS( D( LL ) )-SHIFT )*
     $          ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
            G = E( LL )
            CALL DLARTG( F, G, COSR, SINR, R )
            F = COSR*D( LL ) + SINR*E( LL )
            E( LL ) = COSR*E( LL ) - SINR*D( LL )
            G = SINR*D( LL+1 )
            D( LL+1 ) = COSR*D( LL+1 )
            CALL DLARTG( F, G, COSL, SINL, R )
            D( LL ) = R
            F = COSL*E( LL ) + SINL*D( LL+1 )
            D( LL+1 ) = COSL*D( LL+1 ) - SINL*E( LL )
            G = SINL*E( LL+1 )
            E( LL+1 ) = COSL*E( LL+1 )
            WORK( 1 ) = COSR
            WORK( 1+NM1 ) = SINR
            WORK( 1+NM12 ) = COSL
            WORK( 1+NM13 ) = SINL
            IROT = 1
            DO 130 I = LL + 1, M - 2
               CALL DLARTG( F, G, COSR, SINR, R )
               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 )
               G = SINL*E( I+1 )
               E( I+1 ) = COSL*E( I+1 )
               IROT = IROT + 1
               WORK( IROT ) = COSR
               WORK( IROT+NM1 ) = SINR
               WORK( IROT+NM12 ) = COSL
               WORK( IROT+NM13 ) = SINL
  130       CONTINUE
            CALL DLARTG( F, G, COSR, SINR, R )
            E( M-2 ) = R
            F = COSR*D( M-1 ) + SINR*E( M-1 )
            E( M-1 ) = COSR*E( M-1 ) - SINR*D( M-1 )
            G = SINR*D( M )
            D( M ) = COSR*D( M )
            CALL DLARTG( F, G, COSL, SINL, R )
            D( M-1 ) = R
            F = COSL*E( M-1 ) + SINL*D( M )
            D( M ) = COSL*D( M ) - SINL*E( M-1 )
            IROT = IROT + 1
            WORK( IROT ) = COSR
            WORK( IROT+NM1 ) = SINR
            WORK( IROT+NM12 ) = COSL
            WORK( IROT+NM13 ) = SINL
            E( M-1 ) = F
C
C           Update singular vectors
C
            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 )
C
C           Test convergence
C
            IF( ABS( E( M-1 ) ).LE.THRESH )
     $         E( M-1 ) = ZERO
C
         ELSE
C
C           Chase bulge from bottom to top
C           Save cosines and sines for later singular vector updates
C
            F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
     $          D( M ) )
            G = E( M-1 )
            CALL DLARTG( F, G, COSR, SINR, R )
            F = COSR*D( M ) + SINR*E( M-1 )
            E( M-1 ) = COSR*E( M-1 ) - SINR*D( M )
            G = SINR*D( M-1 )
            D( M-1 ) = COSR*D( M-1 )
            CALL DLARTG( F, G, COSL, SINL, R )
            D( M ) = R
            F = COSL*E( M-1 ) + SINL*D( M-1 )
            D( M-1 ) = COSL*D( M-1 ) - SINL*E( M-1 )
            G = SINL*E( M-2 )
            E( M-2 ) = COSL*E( M-2 )
            WORK( M-LL ) = COSR
            WORK( M-LL+NM1 ) = -SINR
            WORK( M-LL+NM12 ) = COSL
            WORK( M-LL+NM13 ) = -SINL
            IROT = M - LL
            DO 140 I = M - 1, LL + 2, -1
               CALL DLARTG( F, G, COSR, SINR, R )
               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 )
               G = SINL*E( I-2 )
               E( I-2 ) = COSL*E( I-2 )
               IROT = IROT - 1
               WORK( IROT ) = COSR
               WORK( IROT+NM1 ) = -SINR
               WORK( IROT+NM12 ) = COSL
               WORK( IROT+NM13 ) = -SINL
  140       CONTINUE
            CALL DLARTG( F, G, COSR, SINR, R )
            E( LL+1 ) = R
            F = COSR*D( LL+1 ) + SINR*E( LL )
            E( LL ) = COSR*E( LL ) - SINR*D( LL+1 )
            G = SINR*D( LL )
            D( LL ) = COSR*D( LL )
            CALL DLARTG( F, G, COSL, SINL, R )
            D( LL+1 ) = R
            F = COSL*E( LL ) + SINL*D( LL )
            D( LL ) = COSL*D( LL ) - SINL*E( LL )
            IROT = IROT - 1
            WORK( IROT ) = COSR
            WORK( IROT+NM1 ) = -SINR
            WORK( IROT+NM12 ) = COSL
            WORK( IROT+NM13 ) = -SINL
            E( LL ) = F
C
C           Test convergence
C
            IF( ABS( E( LL ) ).LE.THRESH )
     $         E( LL ) = ZERO
C
C           Update singular vectors if desired
C
            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
C
C     QR iteration finished, go back and check convergence
C
      GO TO 50
C
C     All singular values converged, so make them positive
C
  150 CONTINUE
      DO 160 I = 1, N
         IF( D( I ).LT.ZERO ) THEN
            D( I ) = -D( I )
C
C           Change sign of singular vectors, if desired
C
            IF( NCVT.GT.0 )
     $         CALL GSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
         END IF
  160 CONTINUE
C
C     Sort the singular values into decreasing order (insertion sort on
C     singular values, but only one transposition per singular vector)
C
      DO 180 I = 1, N - 1
C
C        Scan for smallest D(I)
C
         ISUB = 1
         SMIN = D( 1 )
         DO 170 J = 2, N + 1 - I
            IF( D( J ).LE.SMIN ) THEN
               ISUB = J
               SMIN = D( J )
            END IF
  170    CONTINUE
         IF( ISUB.NE.N+1-I ) THEN
C
C           Swap singular values and vectors
C
            D( ISUB ) = D( N+1-I )
            D( N+1-I ) = SMIN
            IF( NCVT.GT.0 )
     $         CALL GSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
     $                     LDVT )
            IF( NRU.GT.0 )
     $         CALL GSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
            IF( NCC.GT.0 )
     $         CALL GSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
         END IF
  180 CONTINUE
      GO TO 210
C
C     Maximum number of iterations exceeded, failure to converge
C
  190 CONTINUE
      INFO = 0
      DO 200 I = 1, N - 1
         IF( E( I ).NE.ZERO )
     $      INFO = INFO + 1
  200 CONTINUE
  210 CONTINUE
      RETURN
      END
*Deck DGEBD2
      SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), D( * ), E( * ), TAUP( * ),
     $                   TAUQ( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DGEBD2 reduces a real general m by n matrix A to upper or lower
C  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
C
C  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows in the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns in the matrix A.  N >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the m by n general matrix to be reduced.
C          On exit,
C          if m >= n, the diagonal and the first superdiagonal are
C            overwritten with the upper bidiagonal matrix B; the
C            elements below the diagonal, with the array TAUQ, represent
C            the orthogonal matrix Q as a product of elementary
C            reflectors, and the elements above the first superdiagonal,
C            with the array TAUP, represent the orthogonal matrix P as
C            a product of elementary reflectors;
C          if m < n, the diagonal and the first subdiagonal are
C            overwritten with the lower bidiagonal matrix B; the
C            elements below the first subdiagonal, with the array TAUQ,
C            represent the orthogonal matrix Q as a product of
C            elementary reflectors, and the elements above the diagonal,
C            with the array TAUP, represent the orthogonal matrix P as
C            a product of elementary reflectors.
C          See Further Details.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  D       (output) Real*8 array, dimension (min(M,N))
C          The diagonal elements of the bidiagonal matrix B:
C          D(i) = A(i,i).
C
C  E       (output) Real*8 array, dimension (min(M,N)-1)
C          The off-diagonal elements of the bidiagonal matrix B:
C          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
C          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
C
C  TAUQ    (output) Real*8 array dimension (min(M,N))
C          The scalar factors of the elementary reflectors which
C          represent the orthogonal matrix Q. See Further Details.
C
C  TAUP    (output) Real*8 array, dimension (min(M,N))
C          The scalar factors of the elementary reflectors which
C          represent the orthogonal matrix P. See Further Details.
C
C  WORK    (workspace) Real*8 array, dimension (max(M,N))
C
C  INFO    (output) INTEGER
C          = 0: successful exit.
C          < 0: if INFO = -i, the i-th argument had an illegal value.
C
C  Further Details
C  ===============
C
C  The matrices Q and P are represented as products of elementary
C  reflectors:
C
C  If m >= n,
C
C     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
C
C  Each H(i) and G(i) has the form:
C
C     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
C
C  where tauq and taup are real scalars, and v and u are real vectors;
C  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
C  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
C  tauq is stored in TAUQ(i) and taup in TAUP(i).
C
C  If m < n,
C
C     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
C
C  Each H(i) and G(i) has the form:
C
C     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
C
C  where tauq and taup are real scalars, and v and u are real vectors;
C  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
C  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
C  tauq is stored in TAUQ(i) and taup in TAUP(i).
C
C  The contents of A on exit are illustrated by the following examples:
C
C  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
C
C    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
C    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
C    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
C    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
C    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
C    (  v1  v2  v3  v4  v5 )
C
C  where d and e denote diagonal and off-diagonal elements of B, vi
C  denotes an element of the vector defining H(i), and ui an element of
C  the vector defining G(i).
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters
C
      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) Call GLBErr('DGEBD2',Info)
      IF( M.GE.N ) THEN
C
C        Reduce to upper bidiagonal form
C
         DO 10 I = 1, N
C
C           Generate elementary reflector H(i) to annihilate A(i+1:m,i)
C
            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
C
C           Apply H(i) to A(i:m,i+1:n) from the left
C
            If(I.lt.N)
     $        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 )
C
            IF( I.LT.N ) THEN
C
C              Generate elementary reflector G(i) to annihilate
C              A(i,i+2:n)
C
               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
C
C              Apply G(i) to A(i+1:m,i+1:n) from the right
C
               If(I.lt.M)
     $           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
C
C        Reduce to lower bidiagonal form
C
         DO 20 I = 1, M
C
C           Generate elementary reflector G(i) to annihilate A(i,i+1:n)
C
            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
C
C           Apply G(i) to A(i+1:m,i:n) from the right
C
            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 )
C
            IF( I.LT.M ) THEN
C
C              Generate elementary reflector H(i) to annihilate
C              A(i+2:m,i)
C
               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
C
C              Apply H(i) to A(i+1:m,i+1:n) from the left
C
               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
*Deck DGEBRD
      SUBROUTINE DGEBRD(M,N,A,LDA,D,E,TAUQ,TAUP,WORK,LWORK,INFO)
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), D( * ), E( * ), TAUP( * ),
     $                   TAUQ( * ), WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  DGEBRD reduces a general real M-by-N matrix A to upper or lower
C  bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
C
C  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows in the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns in the matrix A.  N >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the M-by-N general matrix to be reduced.
C          On exit,
C          if m >= n, the diagonal and the first superdiagonal are
C            overwritten with the upper bidiagonal matrix B; the
C            elements below the diagonal, with the array TAUQ, represent
C            the orthogonal matrix Q as a product of elementary
C            reflectors, and the elements above the first superdiagonal,
C            with the array TAUP, represent the orthogonal matrix P as
C            a product of elementary reflectors;
C          if m < n, the diagonal and the first subdiagonal are
C            overwritten with the lower bidiagonal matrix B; the
C            elements below the first subdiagonal, with the array TAUQ,
C            represent the orthogonal matrix Q as a product of
C            elementary reflectors, and the elements above the diagonal,
C            with the array TAUP, represent the orthogonal matrix P as
C            a product of elementary reflectors.
C          See Further Details.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  D       (output) Real*8 array, dimension (min(M,N))
C          The diagonal elements of the bidiagonal matrix B:
C          D(i) = A(i,i).
C
C  E       (output) Real*8 array, dimension (min(M,N)-1)
C          The off-diagonal elements of the bidiagonal matrix B:
C          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
C          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
C
C  TAUQ    (output) Real*8 array dimension (min(M,N))
C          The scalar factors of the elementary reflectors which
C          represent the orthogonal matrix Q. See Further Details.
C
C  TAUP    (output) Real*8 array, dimension (min(M,N))
C          The scalar factors of the elementary reflectors which
C          represent the orthogonal matrix P. See Further Details.
C
C  WORK    (workspace/output) Real*8 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The length of the array WORK.  LWORK >= max(1,M,N).
C          For optimum performance LWORK >= (M+N)*NB, where NB
C          is the optimal blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value.
C
C  Further Details
C  ===============
C
C  The matrices Q and P are represented as products of elementary
C  reflectors:
C
C  If m >= n,
C
C     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
C
C  Each H(i) and G(i) has the form:
C
C     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
C
C  where tauq and taup are real scalars, and v and u are real vectors;
C  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
C  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
C  tauq is stored in TAUQ(i) and taup in TAUP(i).
C
C  If m < n,
C
C     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
C
C  Each H(i) and G(i) has the form:
C
C     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
C
C  where tauq and taup are real scalars, and v and u are real vectors;
C  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
C  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
C  tauq is stored in TAUQ(i) and taup in TAUP(i).
C
C  The contents of A on exit are illustrated by the following examples:
C
C  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
C
C    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
C    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
C    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
C    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
C    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
C    (  v1  v2  v3  v4  v5 )
C
C  where d and e denote diagonal and off-diagonal elements of B, vi
C  denotes an element of the vector defining H(i), and ui an element of
C  the vector defining G(i).
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IINFO, J, LDWRKX, LDWRKY, MINMN, NB, NBMIN,
     $                   NX
      Real*8   WS
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters
C
      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
      ELSE IF( LWORK.LT.MAX( 1, M, N ) ) THEN
         INFO = -10
      END IF
      If(Info.lt.0) Call GLBErr('DGEBrd',Info)
C
C     Quick return if possible
C
      MINMN = MIN( M, N )
      IF( MINMN.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
C
      WS = MAX( M, N )
      LDWRKX = M
      LDWRKY = N
C
C     Set the block size NB and the crossover point NX.
C
      NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) )
C
      IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
C
C        Determine when to switch from blocked to unblocked code.
C
         NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) )
         IF( NX.LT.MINMN ) THEN
            WS = ( M+N )*NB
            IF( LWORK.LT.WS ) THEN
C
C              Not enough work space for the optimal NB, consider using
C              a smaller block size.
C
               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
C
      DO 30 I = 1, MINMN - NX, NB
C
C        Reduce rows and columns i:i+nb-1 to bidiagonal form and return
C        the matrices X and Y which are needed to update the unreduced
C        part of the matrix
C
         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 )
C
C        Update the trailing submatrix A(i+nb:m,i+nb:n), using an update
C        of the form  A := A - V*Y' - X*U'
C
         CALL GGEMM( '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 GGEMM( '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 )
C
C        Copy diagonal and off-diagonal elements of B back into A
C
         IF( M.GE.N ) THEN
            DO 10 J = I, I + NB - 1
               A( J, J ) = D( J )
               A( J, J+1 ) = E( J )
   10       CONTINUE
         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
C
C     Use unblocked code to reduce the remainder of the matrix
C
      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
*Deck DGELQ2
      SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DGELQ2 computes an LQ factorization of a real m by n matrix A:
C  A = L * Q.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the m by n matrix A.
C          On exit, the elements on and below the diagonal of the array
C          contain the m by min(m,n) lower trapezoidal matrix L (L is
C          lower triangular if m <= n); the elements above the diagonal,
C          with the array TAU, represent the orthogonal matrix Q as a
C          product of elementary reflectors (see Further Details).
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  TAU     (output) Real*8 array, dimension (min(M,N))
C          The scalar factors of the elementary reflectors (see Further
C          Details).
C
C  WORK    (workspace) Real*8 array, dimension (M)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument had an illegal value
C
C  Further Details
C  ===============
C
C  The matrix Q is represented as a product of elementary reflectors
C
C     Q = H(k) . . . H(2) H(1), where k = min(m,n).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a real scalar, and v is a real vector with
C  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
C  and tau in TAU(i).
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, K
      Real*8   AII
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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) Call GLBErr('DGELQ2',Info)
      K = MIN( M, N )
C
      DO 10 I = 1, K
C
C        Generate elementary reflector H(i) to annihilate A(i,i+1:n)
C
         CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
     $                TAU( I ) )
         IF( I.LT.M ) THEN
C
C           Apply H(i) to A(i+1:m,i:n) from the right
C
            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
*Deck DGELQF
      SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), TAU( * ), WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  DGELQF computes an LQ factorization of a real M-by-N matrix A:
C  A = L * Q.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the M-by-N matrix A.
C          On exit, the elements on and below the diagonal of the array
C          contain the m-by-min(m,n) lower trapezoidal matrix L (L is
C          lower triangular if m <= n); the elements above the diagonal,
C          with the array TAU, represent the orthogonal matrix Q as a
C          product of elementary reflectors (see Further Details).
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  TAU     (output) Real*8 array, dimension (min(M,N))
C          The scalar factors of the elementary reflectors (see Further
C          Details).
C
C  WORK    (workspace/output) Real*8 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK.  LWORK >= max(1,M).
C          For optimum performance LWORK >= M*NB, where NB is the
C          optimal blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  Further Details
C  ===============
C
C  The matrix Q is represented as a product of elementary reflectors
C
C     Q = H(k) . . . H(2) H(1), where k = min(m,n).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a real scalar, and v is a real vector with
C  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
C  and tau in TAU(i).
C
C  =====================================================================
C
C     .. Local Scalars ..
      INTEGER            I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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
      ELSE IF( LWORK.LT.MAX( 1, M ) ) THEN
         INFO = -7
      END IF
      If(Info.ne.0) Call GLBErr('DGELQF',Info)
C
C     Quick return if possible
C
      K = MIN( M, N )
      IF( K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
C
C     Determine the block size.
C
      NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
      NBMIN = 2
      NX = 0
      IWS = M
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
C
C        Determine when to cross over from blocked to unblocked code.
C
         NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.K ) THEN
C
C           Determine if workspace is large enough for blocked code.
C
            LDWORK = M
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
C
C              Not enough workspace to use optimal NB:  reduce NB and
C              determine the minimum value of NB.
C
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1,
     $                 -1 ) )
            END IF
         END IF
      END IF
C
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
C
C        Use blocked code initially
C
         DO 10 I = 1, K - NX, NB
            IB = MIN( K-I+1, NB )
C
C           Compute the LQ factorization of the current block
C           A(i:i+ib-1,i:n)
C
            CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
     $                   IINFO )
            IF( I+IB.LE.M ) THEN
C
C              Form the triangular factor of the block reflector
C              H = H(i) H(i+1) . . . H(i+ib-1)
C
               CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
     $                      LDA, TAU( I ), WORK, LDWORK )
C
C              Apply H to A(i+ib:m,i:n) from the right
C
               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
C
C     Use unblocked code to factor the last or only block.
C
      IF( I.LE.K )
     $   CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
     $                IINFO )
C
      WORK( 1 ) = IWS
      RETURN
      END
*Deck DGEQR2
      SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DGEQR2 computes a QR factorization of a real m by n matrix A:
C  A = Q * R.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the m by n matrix A.
C          On exit, the elements on and above the diagonal of the array
C          contain the min(m,n) by n upper trapezoidal matrix R (R is
C          upper triangular if m >= n); the elements below the diagonal,
C          with the array TAU, represent the orthogonal matrix Q as a
C          product of elementary reflectors (see Further Details).
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  TAU     (output) Real*8 array, dimension (min(M,N))
C          The scalar factors of the elementary reflectors (see Further
C          Details).
C
C  WORK    (workspace) Real*8 array, dimension (N)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument had an illegal value
C
C  Further Details
C  ===============
C
C  The matrix Q is represented as a product of elementary reflectors
C
C     Q = H(1) H(2) . . . H(k), where k = min(m,n).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a real scalar, and v is a real vector with
C  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
C  and tau in TAU(i).
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, K
      Real*8   AII
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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) Call GLBErr('DGEQR2',Info)
      K = MIN( M, N )
      DO 10 I = 1, K
C
C        Generate elementary reflector H(i) to annihilate A(i+1:m,i)
C
         CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
     $                TAU( I ) )
         IF( I.LT.N ) THEN
C
C           Apply H(i) to A(i:m,i+1:n) from the left
C
            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
*Deck DGEQRF
      SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), TAU( * ), WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  DGEQRF computes a QR factorization of a real M-by-N matrix A:
C  A = Q * R.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the M-by-N matrix A.
C          On exit, the elements on and above the diagonal of the array
C          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
C          upper triangular if m >= n); the elements below the diagonal,
C          with the array TAU, represent the orthogonal matrix Q as a
C          product of min(m,n) elementary reflectors (see Further
C          Details).
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  TAU     (output) Real*8 array, dimension (min(M,N))
C          The scalar factors of the elementary reflectors (see Further
C          Details).
C
C  WORK    (workspace/output) Real*8 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK.  LWORK >= max(1,N).
C          For optimum performance LWORK >= N*NB, where NB is
C          the optimal blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  Further Details
C  ===============
C
C  The matrix Q is represented as a product of elementary reflectors
C
C     Q = H(1) H(2) . . . H(k), where k = min(m,n).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a real scalar, and v is a real vector with
C  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
C  and tau in TAU(i).
C
C  =====================================================================
C
C     .. Local Scalars ..
      INTEGER            I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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
      ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      If(Info.ne.0) Call GLBErr('DGEQRF',Info)
C
C     Quick return if possible
C
      K = MIN( M, N )
      IF( K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
C
C     Determine the block size.
C
      NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
      NBMIN = 2
      NX = 0
      IWS = N
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
C
C        Determine when to cross over from blocked to unblocked code.
C
         NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.K ) THEN
C
C           Determine if workspace is large enough for blocked code.
C
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
C
C              Not enough workspace to use optimal NB:  reduce NB and
C              determine the minimum value of NB.
C
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1,
     $                 -1 ) )
            END IF
         END IF
      END IF
C
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
C
C        Use blocked code initially
C
         DO 10 I = 1, K - NX, NB
            IB = MIN( K-I+1, NB )
C
C           Compute the QR factorization of the current block
C           A(i:m,i:i+ib-1)
C
            CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
     $                   IINFO )
            IF( I+IB.LE.N ) THEN
C
C              Form the triangular factor of the block reflector
C              H = H(i) H(i+1) . . . H(i+ib-1)
C
               CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB,
     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
C
C              Apply H' to A(i:m,i+ib:n) from the left
C
               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
C
C     Use unblocked code to factor the last or only block.
C
      IF( I.LE.K )
     $   CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
     $                IINFO )
C
      WORK( 1 ) = IWS
      RETURN
      END
*Deck DGESV
      SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK driver routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     March 31, 1993
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, N, NRHS
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      Real*8   A( LDA, * ), B( LDB, * )
C     ..
C
C  Purpose
C  =======
C
C  DGESV computes the solution to a real system of linear equations
C     A * X = B,
C  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
C
C  The LU decomposition with partial pivoting and row interchanges is
C  used to factor A as
C     A = P * L * U,
C  where P is a permutation matrix, L is unit lower triangular, and U is
C  upper triangular.  The factored form of A is then used to solve the
C  system of equations A * X = B.
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The number of linear equations, i.e., the order of the
C          matrix A.  N >= 0.
C
C  NRHS    (input) INTEGER
C          The number of right hand sides, i.e., the number of columns
C          of the matrix B.  NRHS >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the N-by-N coefficient matrix A.
C          On exit, the factors L and U from the factorization
C          A = P*L*U; the unit diagonal elements of L are not stored.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,N).
C
C  IPIV    (output) INTEGER array, dimension (N)
C          The pivot indices that define the permutation matrix P;
C          row i of the matrix was interchanged with row IPIV(i).
C
C  B       (input/output) Real*8 array, dimension (LDB,NRHS)
C          On entry, the N-by-NRHS matrix of right hand side matrix B.
C          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
C
C  LDB     (input) INTEGER
C          The leading dimension of the array B.  LDB >= max(1,N).
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C          > 0:  if INFO = i, U(i,i) is exactly zero.  The factorization
C                has been completed, but the factor U is exactly
C                singular, so the solution could not be computed.
C
C  =====================================================================
C
C     Test the input parameters.
C
      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) Call GLBErr('DGESV',Info)
C
C     Compute the LU factorization of A.
C
      CALL DGETRF( N, N, A, LDA, IPIV, INFO )
      IF( INFO.EQ.0 ) THEN
C
C        Solve the system A*X = B, overwriting B with X.
C
         CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
     $                INFO )
      END IF
      RETURN
      END
*Deck DGESVD
      SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
     $                   WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK driver routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          JOBU, JOBVT
      INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), S( * ), U( LDU, * ),
     $                   VT( LDVT, * ), WORK( * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  DGESVD computes the singular value decomposition (SVD) of a real
C  M-by-N matrix A, optionally computing the left and/or right singular
C  vectors. The SVD is written
C
C       A = U * SIGMA * transpose(V)
C
C  where SIGMA is an M-by-N matrix which is zero except for its
C  min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
C  V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA
C  are the singular values of A; they are real and non-negative, and
C  are returned in descending order.  The first min(m,n) columns of
C  U and V are the left and right singular vectors of A.
C
C  Note that the routine returns V**T, not V.
C
C  Arguments
C  =========
C
C  JOBU    (input) CHARACTER*1
C          Specifies options for computing all or part of the matrix U:
C          = 'A':  all M columns of U are returned in array U:
C          = 'S':  the first min(m,n) columns of U (the left singular
C                  vectors) are returned in the array U;
C          = 'O':  the first min(m,n) columns of U (the left singular
C                  vectors) are overwritten on the array A;
C          = 'N':  no columns of U (no left singular vectors) are
C                  computed.
C
C  JOBVT   (input) CHARACTER*1
C          Specifies options for computing all or part of the matrix
C          V**T:
C          = 'A':  all N rows of V**T are returned in the array VT;
C          = 'S':  the first min(m,n) rows of V**T (the right singular
C                  vectors) are returned in the array VT;
C          = 'O':  the first min(m,n) rows of V**T (the right singular
C                  vectors) are overwritten on the array A;
C          = 'N':  no rows of V**T (no right singular vectors) are
C                  computed.
C
C          JOBVT and JOBU cannot both be 'O'.
C
C  M       (input) INTEGER
C          The number of rows of the input matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the input matrix A.  N >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the M-by-N matrix A.
C          On exit,
C          if JOBU = 'O',  A is overwritten with the first min(m,n)
C                          columns of U (the left singular vectors,
C                          stored columnwise);
C          if JOBVT = 'O', A is overwritten with the first min(m,n)
C                          rows of V**T (the right singular vectors,
C                          stored rowwise);
C          if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
C                          are destroyed.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  S       (output) Real*8 array, dimension (min(M,N))
C          The singular values of A, sorted so that S(i) >= S(i+1).
C
C  U       (output) Real*8 array, dimension (LDU,UCOL)
C          (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
C          If JOBU = 'A', U contains the M-by-M orthogonal matrix U;
C          if JOBU = 'S', U contains the first min(m,n) columns of U
C          (the left singular vectors, stored columnwise);
C          if JOBU = 'N' or 'O', U is not referenced.
C
C  LDU     (input) INTEGER
C          The leading dimension of the array U.  LDU >= 1; if
C          JOBU = 'S' or 'A', LDU >= M.
C
C  VT      (output) Real*8 array, dimension (LDVT,N)
C          If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
C          V**T;
C          if JOBVT = 'S', VT contains the first min(m,n) rows of
C          V**T (the right singular vectors, stored rowwise);
C          if JOBVT = 'N' or 'O', VT is not referenced.
C
C  LDVT    (input) INTEGER
C          The leading dimension of the array VT.  LDVT >= 1; if
C          JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
C
C  WORK    (workspace/output) Real*8 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
C          if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged
C          superdiagonal elements of an upper bidiagonal matrix B
C          whose diagonal is in S (not necessarily sorted). B
C          satisfies A = U * B * VT, so it has the same singular values
C          as A, and singular vectors related by U and VT.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK. LWORK >= 1.
C          LWORK >= MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N)-4).
C          For good performance, LWORK should generally be larger.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit.
C          < 0:  if INFO = -i, the i-th argument had an illegal value.
C          > 0:  if DBDSQR did not converge, INFO specifies how many
C                superdiagonals of an intermediate bidiagonal form B
C                did not converge to zero. See the description of WORK
C                above for details.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            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
      Real*8   ANRM, BIGNUM, EPS, SMLNUM
C     ..
C     .. Local Arrays ..
      Real*8   DUM( 1 )
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      MINMN = MIN( M, N )
      MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 )
      WNTUA = GLSame( JOBU, 'A' )
      WNTUS = GLSame( JOBU, 'S' )
      WNTUAS = WNTUA .OR. WNTUS
      WNTUO = GLSame( JOBU, 'O' )
      WNTUN = GLSame( JOBU, 'N' )
      WNTVA = GLSame( JOBVT, 'A' )
      WNTVS = GLSame( JOBVT, 'S' )
      WNTVAS = WNTVA .OR. WNTVS
      WNTVO = GLSame( JOBVT, 'O' )
      WNTVN = GLSame( JOBVT, 'N' )
      MINWRK = 1
C
      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
C
C     Compute workspace
C      (Note: Comments in the code beginning "Workspace:" describe the
C       minimal amount of workspace needed at that point in the code,
C       as well as the preferred amount for good performance.
C       NB refers to the optimal block size for the immediately
C       following subroutine, as returned by ILAENV.)
C
      IF( INFO.EQ.0 .AND. LWORK.GE.1 .AND. M.GT.0 .AND. N.GT.0 ) THEN
         IF( M.GE.N ) THEN
C
C           Compute space needed for DBDSQR
C
            BDSPAC = MAX( 3*N, 5*N-4 )
            IF( M.GE.MNTHR ) THEN
               IF( WNTUN ) THEN
C
C                 Path 1 (M much larger than N, JOBU='N')
C
                  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
C
C                 Path 2 (M much larger than N, JOBU='O', JOBVT='N')
C
                  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
C
C                 Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
C                 'A')
C
                  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
C
C                 Path 4 (M much larger than N, JOBU='S', JOBVT='N')
C
                  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
C
C                 Path 5 (M much larger than N, JOBU='S', JOBVT='O')
C
                  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
C
C                 Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
C                 'A')
C
                  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
C
C                 Path 7 (M much larger than N, JOBU='A', JOBVT='N')
C
                  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
C
C                 Path 8 (M much larger than N, JOBU='A', JOBVT='O')
C
                  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
C
C                 Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
C                 'A')
C
                  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
C
C              Path 10 (M at least N, but not much larger)
C
               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
C
C           Compute space needed for DBDSQR
C
            BDSPAC = MAX( 3*M, 5*M-4 )
            IF( N.GE.MNTHR ) THEN
               IF( WNTVN ) THEN
C
C                 Path 1t(N much larger than M, JOBVT='N')
C
                  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
C
C                 Path 2t(N much larger than M, JOBU='N', JOBVT='O')
C
                  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
C
C                 Path 3t(N much larger than M, JOBU='S' or 'A',
C                 JOBVT='O')
C
                  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
C
C                 Path 4t(N much larger than M, JOBU='N', JOBVT='S')
C
                  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
C
C                 Path 5t(N much larger than M, JOBU='O', JOBVT='S')
C
                  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
C
C                 Path 6t(N much larger than M, JOBU='S' or 'A',
C                 JOBVT='S')
C
                  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
C
C                 Path 7t(N much larger than M, JOBU='N', JOBVT='A')
C
                  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
C
C                 Path 8t(N much larger than M, JOBU='O', JOBVT='A')
C
                  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
C
C                 Path 9t(N much larger than M, JOBU='S' or 'A',
C                 JOBVT='A')
C
                  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
C
C              Path 10t(N greater than M, but not much larger)
C
               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
C
      IF( LWORK.LT.MINWRK ) THEN
         INFO = -13
      END IF
      If(Info.ne.0) Call GLBErr('DGESVD',Info)
C
C     Quick return if possible
C
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         IF( LWORK.GE.1 )
     $      WORK( 1 ) = ONE
         RETURN
      END IF
C
C     Get machine constants
C
      SMLNUM = SQRT( SFMin ) / EPS
      BIGNUM = ONE / SMLNUM
C
C     Scale A if max element outside range [SMLNUM,BIGNUM]
C
      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
C
      IF( M.GE.N ) THEN
C
C        A has at least as many rows as columns. If A has sufficiently
C        more rows than columns, first reduce using the QR
C        decomposition (if sufficient workspace available)
C
         IF( M.GE.MNTHR ) THEN
C
            IF( WNTUN ) THEN
C
C              Path 1 (M much larger than N, JOBU='N')
C              No left singular vectors to be computed
C
               ITAU = 1
               IWORK = ITAU + N
C
C              Compute A=Q*R
C              (Workspace: need 2*N, prefer N+N*NB)
C
               CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
     $                      LWORK-IWORK+1, IERR )
C
C              Zero out below R
C
               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
               IE = 1
               ITAUQ = IE + N
               ITAUP = ITAUQ + N
               IWORK = ITAUP + N
C
C              Bidiagonalize R in A
C              (Workspace: need 4*N, prefer 3*N+2*N*NB)
C
               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
C
C                 If right singular vectors desired, generate P'.
C                 (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
C
                  CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  NCVT = N
               END IF
               IWORK = IE + N
C
C              Perform bidiagonal QR iteration, computing right
C              singular vectors of A in A if desired
C              (Workspace: need BDSPAC)
C
               CALL DBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA,
     $                      DUM, 1, DUM, 1, WORK( IWORK ), INFO )
C
C              If right singular vectors desired in VT, copy them there
C
               IF( WNTVAS )
     $            CALL DLACPY( 'F', N, N, A, LDA, VT, LDVT )
C
            ELSE IF( WNTUO .AND. WNTVN ) THEN
C
C              Path 2 (M much larger than N, JOBU='O', JOBVT='N')
C              N left singular vectors to be overwritten on A and
C              no right singular vectors to be computed
C
               IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
C
C                 Sufficient workspace for a fast algorithm
C
                  IR = 1
                  IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
C
C                    WORK(IU) is LDA by N, WORK(IR) is LDA by N
C
                     LDWRKU = LDA
                     LDWRKR = LDA
                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
C
C                    WORK(IU) is LDA by N, WORK(IR) is N by N
C
                     LDWRKU = LDA
                     LDWRKR = N
                  ELSE
C
C                    WORK(IU) is LDWRKU by N, WORK(IR) is N by N
C
                     LDWRKU = ( LWORK-N*N-N ) / N
                     LDWRKR = N
                  END IF
                  ITAU = IR + LDWRKR*N
                  IWORK = ITAU + N
C
C                 Compute A=Q*R
C                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
C
                  CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Copy R to WORK(IR) and zero out below it
C
                  CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
                  CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
     $                         LDWRKR )
C
C                 Generate Q in A
C                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
C
                  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
C
C                 Bidiagonalize R in WORK(IR)
C                 (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
C
                  CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Generate left vectors bidiagonalizing R
C                 (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
C
                  CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
     $                         WORK( ITAUQ ), WORK( IWORK ),
     $                         LWORK-IWORK+1, IERR )
                  IWORK = IE + N
C
C                 Perform bidiagonal QR iteration, computing left
C                 singular vectors of R in WORK(IR)
C                 (Workspace: need N*N+BDSPAC)
C
                  CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1,
     $                         WORK( IR ), LDWRKR, DUM, 1,
     $                         WORK( IWORK ), INFO )
                  IU = IE + N
C
C                 Multiply Q in A by left singular vectors of R in
C                 WORK(IR), storing result in WORK(IU) and copying to A
C                 (Workspace: need N*N+2*N, prefer N*N+M*N+N)
C
                  DO 10 I = 1, M, LDWRKU
                     CHUNK = MIN( M-I+1, LDWRKU )
                     CALL GGEMM( '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
C
               ELSE
C
C                 Insufficient workspace for a fast algorithm
C
                  IE = 1
                  ITAUQ = IE + N
                  ITAUP = ITAUQ + N
                  IWORK = ITAUP + N
C
C                 Bidiagonalize A
C                 (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
C
                  CALL DGEBRD( M, N, A, LDA, S, WORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Generate left vectors bidiagonalizing A
C                 (Workspace: need 4*N, prefer 3*N+N*NB)
C
                  CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IWORK = IE + N
C
C                 Perform bidiagonal QR iteration, computing left
C                 singular vectors of A in A
C                 (Workspace: need BDSPAC)
C
                  CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1,
     $                         A, LDA, DUM, 1, WORK( IWORK ), INFO )
C
               END IF
C
            ELSE IF( WNTUO .AND. WNTVAS ) THEN
C
C              Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
C              N left singular vectors to be overwritten on A and
C              N right singular vectors to be computed in VT
C
               IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
C
C                 Sufficient workspace for a fast algorithm
C
                  IR = 1
                  IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
C
C                    WORK(IU) is LDA by N and WORK(IR) is LDA by N
C
                     LDWRKU = LDA
                     LDWRKR = LDA
                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
C
C                    WORK(IU) is LDA by N and WORK(IR) is N by N
C
                     LDWRKU = LDA
                     LDWRKR = N
                  ELSE
C
C                    WORK(IU) is LDWRKU by N and WORK(IR) is N by N
C
                     LDWRKU = ( LWORK-N*N-N ) / N
                     LDWRKR = N
                  END IF
                  ITAU = IR + LDWRKR*N
                  IWORK = ITAU + N
C
C                 Compute A=Q*R
C                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
C
                  CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Copy R to VT, zeroing out below it
C
                  CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
                  CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ),
     $                         LDVT )
C
C                 Generate Q in A
C                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
C
                  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
C
C                 Bidiagonalize R in VT, copying result to WORK(IR)
C                 (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
C
                  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 )
C
C                 Generate left vectors bidiagonalizing R in WORK(IR)
C                 (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
C
                  CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
     $                         WORK( ITAUQ ), WORK( IWORK ),
     $                         LWORK-IWORK+1, IERR )
C
C                 Generate right vectors bidiagonalizing R in VT
C                 (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB)
C
                  CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IWORK = IE + N
C
C                 Perform bidiagonal QR iteration, computing left
C                 singular vectors of R in WORK(IR) and computing right
C                 singular vectors of R in VT
C                 (Workspace: need N*N+BDSPAC)
C
                  CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT,
     $                         WORK( IR ), LDWRKR, DUM, 1,
     $                         WORK( IWORK ), INFO )
                  IU = IE + N
C
C                 Multiply Q in A by left singular vectors of R in
C                 WORK(IR), storing result in WORK(IU) and copying to A
C                 (Workspace: need N*N+2*N, prefer N*N+M*N+N)
C
                  DO 20 I = 1, M, LDWRKU
                     CHUNK = MIN( M-I+1, LDWRKU )
                     CALL GGEMM( '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
C
               ELSE
C
C                 Insufficient workspace for a fast algorithm
C
                  ITAU = 1
                  IWORK = ITAU + N
C
C                 Compute A=Q*R
C                 (Workspace: need 2*N, prefer N+N*NB)
C
                  CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Copy R to VT, zeroing out below it
C
                  CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
                  CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ),
     $                         LDVT )
C
C                 Generate Q in A
C                 (Workspace: need 2*N, prefer N+N*NB)
C
                  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
C
C                 Bidiagonalize R in VT
C                 (Workspace: need 4*N, prefer 3*N+2*N*NB)
C
                  CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Multiply Q in A by left vectors bidiagonalizing R
C                 (Workspace: need 3*N+M, prefer 3*N+M*NB)
C
                  CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
     $                         WORK( ITAUQ ), A, LDA, WORK( IWORK ),
     $                         LWORK-IWORK+1, IERR )
C
C                 Generate right vectors bidiagonalizing R in VT
C                 (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
C
                  CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IWORK = IE + N
C
C                 Perform bidiagonal QR iteration, computing left
C                 singular vectors of A in A and computing right
C                 singular vectors of A in VT
C                 (Workspace: need BDSPAC)
C
                  CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT,
     $                         A, LDA, DUM, 1, WORK( IWORK ), INFO )
C
               END IF
C
            ELSE IF( WNTUS ) THEN
C
               IF( WNTVN ) THEN
C
C                 Path 4 (M much larger than N, JOBU='S', JOBVT='N')
C                 N left singular vectors to be computed in U and
C                 no right singular vectors to be computed
C
                  IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IR = 1
                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
C
C                       WORK(IR) is LDA by N
C
                        LDWRKR = LDA
                     ELSE
C
C                       WORK(IR) is N by N
C
                        LDWRKR = N
                     END IF
                     ITAU = IR + LDWRKR*N
                     IWORK = ITAU + N
C
C                    Compute A=Q*R
C                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
C
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R to WORK(IR), zeroing out below it
C
                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ),
     $                            LDWRKR )
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
     $                            WORK( IR+1 ), LDWRKR )
C
C                    Generate Q in A
C                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
C
                     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
C
C                    Bidiagonalize R in WORK(IR)
C                    (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
C
                     CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S,
     $                            WORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate left vectors bidiagonalizing R in WORK(IR)
C                    (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
C
                     CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of R in WORK(IR)
C                    (Workspace: need N*N+BDSPAC)
C
                     CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
     $                            1, WORK( IR ), LDWRKR, DUM, 1,
     $                            WORK( IWORK ), INFO )
C
C                    Multiply Q in A by left singular vectors of R in
C                    WORK(IR), storing result in U
C                    (Workspace: need N*N)
C
                     CALL GGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
     $                           WORK( IR ), LDWRKR, ZERO, U, LDU )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (Workspace: need 2*N, prefer N+N*NB)
C
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (Workspace: need 2*N, prefer N+N*NB)
C
                     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
C
C                    Zero out below R in A
C
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
     $                            LDA )
C
C                    Bidiagonalize R in A
C                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
C
                     CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply Q in U by left vectors bidiagonalizing R
C                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
C
                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U
C                    (Workspace: need BDSPAC)
C
                     CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
     $                            1, U, LDU, DUM, 1, WORK( IWORK ),
     $                            INFO )
C
                  END IF
C
               ELSE IF( WNTVO ) THEN
C
C                 Path 5 (M much larger than N, JOBU='S', JOBVT='O')
C                 N left singular vectors to be computed in U and
C                 N right singular vectors to be overwritten on A
C
                  IF( LWORK.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
C
C                       WORK(IU) is LDA by N and WORK(IR) is LDA by N
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*N
                        LDWRKR = LDA
                     ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
C
C                       WORK(IU) is LDA by N and WORK(IR) is N by N
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*N
                        LDWRKR = N
                     ELSE
C
C                       WORK(IU) is N by N and WORK(IR) is N by N
C
                        LDWRKU = N
                        IR = IU + LDWRKU*N
                        LDWRKR = N
                     END IF
                     ITAU = IR + LDWRKR*N
                     IWORK = ITAU + N
C
C                    Compute A=Q*R
C                    (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
C
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R to WORK(IU), zeroing out below it
C
                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
     $                            LDWRKU )
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
     $                            WORK( IU+1 ), LDWRKU )
C
C                    Generate Q in A
C                    (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
C
                     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
C
C                    Bidiagonalize R in WORK(IU), copying result to
C                    WORK(IR)
C                    (Workspace: need 2*N*N+4*N,
C                                prefer 2*N*N+3*N+2*N*NB)
C
                     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 )
C
C                    Generate left bidiagonalizing vectors in WORK(IU)
C                    (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
C
                     CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in WORK(IR)
C                    (Workspace: need 2*N*N+4*N-1,
C                                prefer 2*N*N+3*N+(N-1)*NB)
C
                     CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of R in WORK(IU) and computing
C                    right singular vectors of R in WORK(IR)
C                    (Workspace: need 2*N*N+BDSPAC)
C
                     CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
     $                            WORK( IR ), LDWRKR, WORK( IU ),
     $                            LDWRKU, DUM, 1, WORK( IWORK ), INFO )
C
C                    Multiply Q in A by left singular vectors of R in
C                    WORK(IU), storing result in U
C                    (Workspace: need N*N)
C
                     CALL GGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
     $                           WORK( IU ), LDWRKU, ZERO, U, LDU )
C
C                    Copy right singular vectors of R to A
C                    (Workspace: need N*N)
C
                     CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
     $                            LDA )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (Workspace: need 2*N, prefer N+N*NB)
C
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (Workspace: need 2*N, prefer N+N*NB)
C
                     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
C
C                    Zero out below R in A
C
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
     $                            LDA )
C
C                    Bidiagonalize R in A
C                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
C
                     CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply Q in U by left vectors bidiagonalizing R
C                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
C
                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right vectors bidiagonalizing R in A
C                    (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
C
                     CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U and computing right
C                    singular vectors of A in A
C                    (Workspace: need BDSPAC)
C
                     CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
     $                            LDA, U, LDU, DUM, 1, WORK( IWORK ),
     $                            INFO )
C
                  END IF
C
               ELSE IF( WNTVAS ) THEN
C
C                 Path 6 (M much larger than N, JOBU='S', JOBVT='S'
C                         or 'A')
C                 N left singular vectors to be computed in U and
C                 N right singular vectors to be computed in VT
C
                  IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
C
C                       WORK(IU) is LDA by N
C
                        LDWRKU = LDA
                     ELSE
C
C                       WORK(IU) is N by N
C
                        LDWRKU = N
                     END IF
                     ITAU = IU + LDWRKU*N
                     IWORK = ITAU + N
C
C                    Compute A=Q*R
C                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
C
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R to WORK(IU), zeroing out below it
C
                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
     $                            LDWRKU )
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
     $                            WORK( IU+1 ), LDWRKU )
C
C                    Generate Q in A
C                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
C
                     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
C
C                    Bidiagonalize R in WORK(IU), copying result to VT
C                    (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
C
                     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 )
C
C                    Generate left bidiagonalizing vectors in WORK(IU)
C                    (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
C
                     CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in VT
C                    (Workspace: need N*N+4*N-1,
C                                prefer N*N+3*N+(N-1)*NB)
C
                     CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of R in WORK(IU) and computing
C                    right singular vectors of R in VT
C                    (Workspace: need N*N+BDSPAC)
C
                     CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
     $                            LDVT, WORK( IU ), LDWRKU, DUM, 1,
     $                            WORK( IWORK ), INFO )
C
C                    Multiply Q in A by left singular vectors of R in
C                    WORK(IU), storing result in U
C                    (Workspace: need N*N)
C
                     CALL GGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
     $                           WORK( IU ), LDWRKU, ZERO, U, LDU )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (Workspace: need 2*N, prefer N+N*NB)
C
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (Workspace: need 2*N, prefer N+N*NB)
C
                     CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R to VT, zeroing out below it
C
                     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
C
C                    Bidiagonalize R in VT
C                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
C
                     CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply Q in U by left bidiagonalizing vectors
C                    in VT
C                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
C
                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in VT
C                    (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
C
                     CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U and computing right
C                    singular vectors of A in VT
C                    (Workspace: need BDSPAC)
C
                     CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
     $                            LDVT, U, LDU, DUM, 1, WORK( IWORK ),
     $                            INFO )
C
                  END IF
C
               END IF
C
            ELSE IF( WNTUA ) THEN
C
               IF( WNTVN ) THEN
C
C                 Path 7 (M much larger than N, JOBU='A', JOBVT='N')
C                 M left singular vectors to be computed in U and
C                 no right singular vectors to be computed
C
                  IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IR = 1
                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
C
C                       WORK(IR) is LDA by N
C
                        LDWRKR = LDA
                     ELSE
C
C                       WORK(IR) is N by N
C
                        LDWRKR = N
                     END IF
                     ITAU = IR + LDWRKR*N
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
C
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Copy R to WORK(IR), zeroing out below it
C
                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ),
     $                            LDWRKR )
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
     $                            WORK( IR+1 ), LDWRKR )
C
C                    Generate Q in U
C                    (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
C
                     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
C
C                    Bidiagonalize R in WORK(IR)
C                    (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
C
                     CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S,
     $                            WORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in WORK(IR)
C                    (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
C
                     CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of R in WORK(IR)
C                    (Workspace: need N*N+BDSPAC)
C
                     CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
     $                            1, WORK( IR ), LDWRKR, DUM, 1,
     $                            WORK( IWORK ), INFO )
C
C                    Multiply Q in U by left singular vectors of R in
C                    WORK(IR), storing result in A
C                    (Workspace: need N*N)
C
                     CALL GGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
     $                           WORK( IR ), LDWRKR, ZERO, A, LDA )
C
C                    Copy left singular vectors of A from A to U
C
                     CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (Workspace: need 2*N, prefer N+N*NB)
C
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (Workspace: need N+M, prefer N+M*NB)
C
                     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
C
C                    Zero out below R in A
C
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
     $                            LDA )
C
C                    Bidiagonalize R in A
C                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
C
                     CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply Q in U by left bidiagonalizing vectors
C                    in A
C                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
C
                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U
C                    (Workspace: need BDSPAC)
C
                     CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
     $                            1, U, LDU, DUM, 1, WORK( IWORK ),
     $                            INFO )
C
                  END IF
C
               ELSE IF( WNTVO ) THEN
C
C                 Path 8 (M much larger than N, JOBU='A', JOBVT='O')
C                 M left singular vectors to be computed in U and
C                 N right singular vectors to be overwritten on A
C
                  IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
C
C                       WORK(IU) is LDA by N and WORK(IR) is LDA by N
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*N
                        LDWRKR = LDA
                     ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
C
C                       WORK(IU) is LDA by N and WORK(IR) is N by N
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*N
                        LDWRKR = N
                     ELSE
C
C                       WORK(IU) is N by N and WORK(IR) is N by N
C
                        LDWRKU = N
                        IR = IU + LDWRKU*N
                        LDWRKR = N
                     END IF
                     ITAU = IR + LDWRKR*N
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
C
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
C
                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R to WORK(IU), zeroing out below it
C
                     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
C
C                    Bidiagonalize R in WORK(IU), copying result to
C                    WORK(IR)
C                    (Workspace: need 2*N*N+4*N,
C                                prefer 2*N*N+3*N+2*N*NB)
C
                     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 )
C
C                    Generate left bidiagonalizing vectors in WORK(IU)
C                    (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
C
                     CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in WORK(IR)
C                    (Workspace: need 2*N*N+4*N-1,
C                                prefer 2*N*N+3*N+(N-1)*NB)
C
                     CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of R in WORK(IU) and computing
C                    right singular vectors of R in WORK(IR)
C                    (Workspace: need 2*N*N+BDSPAC)
C
                     CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
     $                            WORK( IR ), LDWRKR, WORK( IU ),
     $                            LDWRKU, DUM, 1, WORK( IWORK ), INFO )
C
C                    Multiply Q in U by left singular vectors of R in
C                    WORK(IU), storing result in A
C                    (Workspace: need N*N)
C
                     CALL GGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
     $                           WORK( IU ), LDWRKU, ZERO, A, LDA )
C
C                    Copy left singular vectors of A from A to U
C
                     CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
C
C                    Copy right singular vectors of R from WORK(IR) to A
C
                     CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
     $                            LDA )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (Workspace: need 2*N, prefer N+N*NB)
C
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (Workspace: need N+M, prefer N+M*NB)
C
                     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
C
C                    Zero out below R in A
C
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
     $                            LDA )
C
C                    Bidiagonalize R in A
C                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
C
                     CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply Q in U by left bidiagonalizing vectors
C                    in A
C                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
C
                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in A
C                    (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
C
                     CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U and computing right
C                    singular vectors of A in A
C                    (Workspace: need BDSPAC)
C
                     CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
     $                            LDA, U, LDU, DUM, 1, WORK( IWORK ),
     $                            INFO )
C
                  END IF
C
               ELSE IF( WNTVAS ) THEN
C
C                 Path 9 (M much larger than N, JOBU='A', JOBVT='S'
C                         or 'A')
C                 M left singular vectors to be computed in U and
C                 N right singular vectors to be computed in VT
C
                  IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
C
C                       WORK(IU) is LDA by N
C
                        LDWRKU = LDA
                     ELSE
C
C                       WORK(IU) is N by N
C
                        LDWRKU = N
                     END IF
                     ITAU = IU + LDWRKU*N
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
C
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
C
                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R to WORK(IU), zeroing out below it
C
                     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
C
C                    Bidiagonalize R in WORK(IU), copying result to VT
C                    (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
C
                     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 )
C
C                    Generate left bidiagonalizing vectors in WORK(IU)
C                    (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
C
                     CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in VT
C                    (Workspace: need N*N+4*N-1,
C                                prefer N*N+3*N+(N-1)*NB)
C
                     CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of R in WORK(IU) and computing
C                    right singular vectors of R in VT
C                    (Workspace: need N*N+BDSPAC)
C
                     CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
     $                            LDVT, WORK( IU ), LDWRKU, DUM, 1,
     $                            WORK( IWORK ), INFO )
C
C                    Multiply Q in U by left singular vectors of R in
C                    WORK(IU), storing result in A
C                    (Workspace: need N*N)
C
                     CALL GGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
     $                           WORK( IU ), LDWRKU, ZERO, A, LDA )
C
C                    Copy left singular vectors of A from A to U
C
                     CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (Workspace: need 2*N, prefer N+N*NB)
C
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (Workspace: need N+M, prefer N+M*NB)
C
                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R from A to VT, zeroing out below it
C
                     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
C
C                    Bidiagonalize R in VT
C                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
C
                     CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply Q in U by left bidiagonalizing vectors
C                    in VT
C                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
C
                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in VT
C                    (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
C
                     CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U and computing right
C                    singular vectors of A in VT
C                    (Workspace: need BDSPAC)
C
                     CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
     $                            LDVT, U, LDU, DUM, 1, WORK( IWORK ),
     $                            INFO )
C
                  END IF
C
               END IF
C
            END IF
C
         ELSE
C
C           M .LT. MNTHR
C
C           Path 10 (M at least N, but not much larger)
C           Reduce to bidiagonal form without QR decomposition
C
            IE = 1
            ITAUQ = IE + N
            ITAUP = ITAUQ + N
            IWORK = ITAUP + N
C
C           Bidiagonalize A
C           (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
C
            CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
     $                   WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
     $                   IERR )
            IF( WNTUAS ) THEN
C
C              If left singular vectors desired in U, copy result to U
C              and generate left bidiagonalizing vectors in U
C              (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB)
C
               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
C
C              If right singular vectors desired in VT, copy result to
C              VT and generate right bidiagonalizing vectors in VT
C              (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
C
               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
C
C              If left singular vectors desired in A, generate left
C              bidiagonalizing vectors in A
C              (Workspace: need 4*N, prefer 3*N+N*NB)
C
               CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTVO ) THEN
C
C              If right singular vectors desired in A, generate right
C              bidiagonalizing vectors in A
C              (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
C
               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
C
C              Perform bidiagonal QR iteration, if desired, computing
C              left singular vectors in U and computing right singular
C              vectors in VT
C              (Workspace: need BDSPAC)
C
               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
C
C              Perform bidiagonal QR iteration, if desired, computing
C              left singular vectors in U and computing right singular
C              vectors in A
C              (Workspace: need BDSPAC)
C
               CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
     $                      U, LDU, DUM, 1, WORK( IWORK ), INFO )
            ELSE
C
C              Perform bidiagonal QR iteration, if desired, computing
C              left singular vectors in A and computing right singular
C              vectors in VT
C              (Workspace: need BDSPAC)
C
               CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
     $                      LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
            END IF
C
         END IF
C
      ELSE
C
C        A has more columns than rows. If A has sufficiently more
C        columns than rows, first reduce using the LQ decomposition (if
C        sufficient workspace available)
C
         IF( N.GE.MNTHR ) THEN
C
            IF( WNTVN ) THEN
C
C              Path 1t(N much larger than M, JOBVT='N')
C              No right singular vectors to be computed
C
               ITAU = 1
               IWORK = ITAU + M
C
C              Compute A=L*Q
C              (Workspace: need 2*M, prefer M+M*NB)
C
               CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
     $                      LWORK-IWORK+1, IERR )
C
C              Zero out above L
C
               CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
               IE = 1
               ITAUQ = IE + M
               ITAUP = ITAUQ + M
               IWORK = ITAUP + M
C
C              Bidiagonalize L in A
C              (Workspace: need 4*M, prefer 3*M+2*M*NB)
C
               CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
     $                      WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
     $                      IERR )
               IF( WNTUO .OR. WNTUAS ) THEN
C
C                 If left singular vectors desired, generate Q
C                 (Workspace: need 4*M, prefer 3*M+M*NB)
C
                  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
C
C              Perform bidiagonal QR iteration, computing left singular
C              vectors of A in A if desired
C              (Workspace: need BDSPAC)
C
               CALL DBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A,
     $                      LDA, DUM, 1, WORK( IWORK ), INFO )
C
C              If left singular vectors desired in U, copy them there
C
               IF( WNTUAS )
     $            CALL DLACPY( 'F', M, M, A, LDA, U, LDU )
C
            ELSE IF( WNTVO .AND. WNTUN ) THEN
C
C              Path 2t(N much larger than M, JOBU='N', JOBVT='O')
C              M right singular vectors to be overwritten on A and
C              no left singular vectors to be computed
C
               IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
C
C                 Sufficient workspace for a fast algorithm
C
                  IR = 1
                  IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
C
C                    WORK(IU) is LDA by N and WORK(IR) is LDA by M
C
                     LDWRKU = LDA
                     CHUNK = N
                     LDWRKR = LDA
                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
C
C                    WORK(IU) is LDA by N and WORK(IR) is M by M
C
                     LDWRKU = LDA
                     CHUNK = N
                     LDWRKR = M
                  ELSE
C
C                    WORK(IU) is M by CHUNK and WORK(IR) is M by M
C
                     LDWRKU = M
                     CHUNK = ( LWORK-M*M-M ) / M
                     LDWRKR = M
                  END IF
                  ITAU = IR + LDWRKR*M
                  IWORK = ITAU + M
C
C                 Compute A=L*Q
C                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
C
                  CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Copy L to WORK(IR) and zero out above it
C
                  CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
                  CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
     $                         WORK( IR+LDWRKR ), LDWRKR )
C
C                 Generate Q in A
C                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
C
                  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
C
C                 Bidiagonalize L in WORK(IR)
C                 (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
C
                  CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Generate right vectors bidiagonalizing L
C                 (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
C
                  CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
     $                         WORK( ITAUP ), WORK( IWORK ),
     $                         LWORK-IWORK+1, IERR )
                  IWORK = IE + M
C
C                 Perform bidiagonal QR iteration, computing right
C                 singular vectors of L in WORK(IR)
C                 (Workspace: need M*M+BDSPAC)
C
                  CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
     $                         WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
     $                         WORK( IWORK ), INFO )
                  IU = IE + M
C
C                 Multiply right singular vectors of L in WORK(IR) by Q
C                 in A, storing result in WORK(IU) and copying to A
C                 (Workspace: need M*M+2*M, prefer M*M+M*N+M)
C
                  DO 30 I = 1, N, CHUNK
                     BLK = MIN( N-I+1, CHUNK )
                     CALL GGEMM( '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
C
               ELSE
C
C                 Insufficient workspace for a fast algorithm
C
                  IE = 1
                  ITAUQ = IE + M
                  ITAUP = ITAUQ + M
                  IWORK = ITAUP + M
C
C                 Bidiagonalize A
C                 (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
C
                  CALL DGEBRD( M, N, A, LDA, S, WORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Generate right vectors bidiagonalizing A
C                 (Workspace: need 4*M, prefer 3*M+M*NB)
C
                  CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IWORK = IE + M
C
C                 Perform bidiagonal QR iteration, computing right
C                 singular vectors of A in A
C                 (Workspace: need BDSPAC)
C
                  CALL DBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA,
     $                         DUM, 1, DUM, 1, WORK( IWORK ), INFO )
C
               END IF
C
            ELSE IF( WNTVO .AND. WNTUAS ) THEN
C
C              Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
C              M right singular vectors to be overwritten on A and
C              M left singular vectors to be computed in U
C
               IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
C
C                 Sufficient workspace for a fast algorithm
C
                  IR = 1
                  IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
C
C                    WORK(IU) is LDA by N and WORK(IR) is LDA by M
C
                     LDWRKU = LDA
                     CHUNK = N
                     LDWRKR = LDA
                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
C
C                    WORK(IU) is LDA by N and WORK(IR) is M by M
C
                     LDWRKU = LDA
                     CHUNK = N
                     LDWRKR = M
                  ELSE
C
C                    WORK(IU) is M by CHUNK and WORK(IR) is M by M
C
                     LDWRKU = M
                     CHUNK = ( LWORK-M*M-M ) / M
                     LDWRKR = M
                  END IF
                  ITAU = IR + LDWRKR*M
                  IWORK = ITAU + M
C
C                 Compute A=L*Q
C                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
C
                  CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Copy L to U, zeroing about above it
C
                  CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
                  CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
     $                         LDU )
C
C                 Generate Q in A
C                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
C
                  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
C
C                 Bidiagonalize L in U, copying result to WORK(IR)
C                 (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
C
                  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 )
C
C                 Generate right vectors bidiagonalizing L in WORK(IR)
C                 (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
C
                  CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
     $                         WORK( ITAUP ), WORK( IWORK ),
     $                         LWORK-IWORK+1, IERR )
C
C                 Generate left vectors bidiagonalizing L in U
C                 (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
C
                  CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IWORK = IE + M
C
C                 Perform bidiagonal QR iteration, computing left
C                 singular vectors of L in U, and computing right
C                 singular vectors of L in WORK(IR)
C                 (Workspace: need M*M+BDSPAC)
C
                  CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
     $                         WORK( IR ), LDWRKR, U, LDU, DUM, 1,
     $                         WORK( IWORK ), INFO )
                  IU = IE + M
C
C                 Multiply right singular vectors of L in WORK(IR) by Q
C                 in A, storing result in WORK(IU) and copying to A
C                 (Workspace: need M*M+2*M, prefer M*M+M*N+M))
C
                  DO 40 I = 1, N, CHUNK
                     BLK = MIN( N-I+1, CHUNK )
                     CALL GGEMM( '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
C
               ELSE
C
C                 Insufficient workspace for a fast algorithm
C
                  ITAU = 1
                  IWORK = ITAU + M
C
C                 Compute A=L*Q
C                 (Workspace: need 2*M, prefer M+M*NB)
C
                  CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Copy L to U, zeroing out above it
C
                  CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
                  CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
     $                         LDU )
C
C                 Generate Q in A
C                 (Workspace: need 2*M, prefer M+M*NB)
C
                  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
C
C                 Bidiagonalize L in U
C                 (Workspace: need 4*M, prefer 3*M+2*M*NB)
C
                  CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Multiply right vectors bidiagonalizing L by Q in A
C                 (Workspace: need 3*M+N, prefer 3*M+N*NB)
C
                  CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
     $                         WORK( ITAUP ), A, LDA, WORK( IWORK ),
     $                         LWORK-IWORK+1, IERR )
C
C                 Generate left vectors bidiagonalizing L in U
C                 (Workspace: need 4*M, prefer 3*M+M*NB)
C
                  CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IWORK = IE + M
C
C                 Perform bidiagonal QR iteration, computing left
C                 singular vectors of A in U and computing right
C                 singular vectors of A in A
C                 (Workspace: need BDSPAC)
C
                  CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA,
     $                         U, LDU, DUM, 1, WORK( IWORK ), INFO )
C
               END IF
C
            ELSE IF( WNTVS ) THEN
C
               IF( WNTUN ) THEN
C
C                 Path 4t(N much larger than M, JOBU='N', JOBVT='S')
C                 M right singular vectors to be computed in VT and
C                 no left singular vectors to be computed
C
                  IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IR = 1
                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
C
C                       WORK(IR) is LDA by M
C
                        LDWRKR = LDA
                     ELSE
C
C                       WORK(IR) is M by M
C
                        LDWRKR = M
                     END IF
                     ITAU = IR + LDWRKR*M
                     IWORK = ITAU + M
C
C                    Compute A=L*Q
C                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
C
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to WORK(IR), zeroing out above it
C
                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ),
     $                            LDWRKR )
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
     $                            WORK( IR+LDWRKR ), LDWRKR )
C
C                    Generate Q in A
C                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
C
                     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
C
C                    Bidiagonalize L in WORK(IR)
C                    (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
C
                     CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S,
     $                            WORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right vectors bidiagonalizing L in
C                    WORK(IR)
C                    (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
C
                     CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing right
C                    singular vectors of L in WORK(IR)
C                    (Workspace: need M*M+BDSPAC)
C
                     CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
     $                            WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
     $                            WORK( IWORK ), INFO )
C
C                    Multiply right singular vectors of L in WORK(IR) by
C                    Q in A, storing result in VT
C                    (Workspace: need M*M)
C
                     CALL GGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
     $                           LDWRKR, A, LDA, ZERO, VT, LDVT )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + M
C
C                    Compute A=L*Q
C                    (Workspace: need 2*M, prefer M+M*NB)
C
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy result to VT
C
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (Workspace: need 2*M, prefer M+M*NB)
C
                     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
C
C                    Zero out above L in A
C
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
     $                            LDA )
C
C                    Bidiagonalize L in A
C                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
C
                     CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply right vectors bidiagonalizing L by Q in VT
C                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
C
                     CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
     $                            WORK( ITAUP ), VT, LDVT,
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing right
C                    singular vectors of A in VT
C                    (Workspace: need BDSPAC)
C
                     CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
     $                            LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
     $                            INFO )
C
                  END IF
C
               ELSE IF( WNTUO ) THEN
C
C                 Path 5t(N much larger than M, JOBU='O', JOBVT='S')
C                 M right singular vectors to be computed in VT and
C                 M left singular vectors to be overwritten on A
C
                  IF( LWORK.GE.2*M*M+MAX( 4*M, BDSPAC ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
C
C                       WORK(IU) is LDA by M and WORK(IR) is LDA by M
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*M
                        LDWRKR = LDA
                     ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
C
C                       WORK(IU) is LDA by M and WORK(IR) is M by M
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*M
                        LDWRKR = M
                     ELSE
C
C                       WORK(IU) is M by M and WORK(IR) is M by M
C
                        LDWRKU = M
                        IR = IU + LDWRKU*M
                        LDWRKR = M
                     END IF
                     ITAU = IR + LDWRKR*M
                     IWORK = ITAU + M
C
C                    Compute A=L*Q
C                    (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
C
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to WORK(IU), zeroing out below it
C
                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
     $                            LDWRKU )
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
     $                            WORK( IU+LDWRKU ), LDWRKU )
C
C                    Generate Q in A
C                    (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
C
                     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
C
C                    Bidiagonalize L in WORK(IU), copying result to
C                    WORK(IR)
C                    (Workspace: need 2*M*M+4*M,
C                                prefer 2*M*M+3*M+2*M*NB)
C
                     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 )
C
C                    Generate right bidiagonalizing vectors in WORK(IU)
C                    (Workspace: need 2*M*M+4*M-1,
C                                prefer 2*M*M+3*M+(M-1)*NB)
C
                     CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in WORK(IR)
C                    (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
C
                     CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of L in WORK(IR) and computing
C                    right singular vectors of L in WORK(IU)
C                    (Workspace: need 2*M*M+BDSPAC)
C
                     CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
     $                            WORK( IU ), LDWRKU, WORK( IR ),
     $                            LDWRKR, DUM, 1, WORK( IWORK ), INFO )
C
C                    Multiply right singular vectors of L in WORK(IU) by
C                    Q in A, storing result in VT
C                    (Workspace: need M*M)
C
                     CALL GGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
     $                           LDWRKU, A, LDA, ZERO, VT, LDVT )
C
C                    Copy left singular vectors of L to A
C                    (Workspace: need M*M)
C
                     CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
     $                            LDA )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (Workspace: need 2*M, prefer M+M*NB)
C
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (Workspace: need 2*M, prefer M+M*NB)
C
                     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
C
C                    Zero out above L in A
C
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
     $                            LDA )
C
C                    Bidiagonalize L in A
C                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
C
                     CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply right vectors bidiagonalizing L by Q in VT
C                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
C
                     CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
     $                            WORK( ITAUP ), VT, LDVT,
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors of L in A
C                    (Workspace: need 4*M, prefer 3*M+M*NB)
C
                     CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
C
C                    Perform bidiagonal QR iteration, compute left
C                    singular vectors of A in A and compute right
C                    singular vectors of A in VT
C                    (Workspace: need BDSPAC)
C
                     CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
     $                            LDVT, A, LDA, DUM, 1, WORK( IWORK ),
     $                            INFO )
C
                  END IF
C
               ELSE IF( WNTUAS ) THEN
C
C                 Path 6t(N much larger than M, JOBU='S' or 'A',
C                         JOBVT='S')
C                 M right singular vectors to be computed in VT and
C                 M left singular vectors to be computed in U
C
                  IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
C
C                       WORK(IU) is LDA by N
C
                        LDWRKU = LDA
                     ELSE
C
C                       WORK(IU) is LDA by M
C
                        LDWRKU = M
                     END IF
                     ITAU = IU + LDWRKU*M
                     IWORK = ITAU + M
C
C                    Compute A=L*Q
C                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
C
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to WORK(IU), zeroing out above it
C
                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
     $                            LDWRKU )
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
     $                            WORK( IU+LDWRKU ), LDWRKU )
C
C                    Generate Q in A
C                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
C
                     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
C
C                    Bidiagonalize L in WORK(IU), copying result to U
C                    (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
C
                     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 )
C
C                    Generate right bidiagonalizing vectors in WORK(IU)
C                    (Workspace: need M*M+4*M-1,
C                                prefer M*M+3*M+(M-1)*NB)
C
                     CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in U
C                    (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
C
                     CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of L in U and computing right
C                    singular vectors of L in WORK(IU)
C                    (Workspace: need M*M+BDSPAC)
C
                     CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
     $                            WORK( IU ), LDWRKU, U, LDU, DUM, 1,
     $                            WORK( IWORK ), INFO )
C
C                    Multiply right singular vectors of L in WORK(IU) by
C                    Q in A, storing result in VT
C                    (Workspace: need M*M)
C
                     CALL GGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
     $                           LDWRKU, A, LDA, ZERO, VT, LDVT )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (Workspace: need 2*M, prefer M+M*NB)
C
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (Workspace: need 2*M, prefer M+M*NB)
C
                     CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to U, zeroing out above it
C
                     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
C
C                    Bidiagonalize L in U
C                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
C
                     CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply right bidiagonalizing vectors in U by Q
C                    in VT
C                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
C
                     CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
     $                            WORK( ITAUP ), VT, LDVT,
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in U
C                    (Workspace: need 4*M, prefer 3*M+M*NB)
C
                     CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U and computing right
C                    singular vectors of A in VT
C                    (Workspace: need BDSPAC)
C
                     CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
     $                            LDVT, U, LDU, DUM, 1, WORK( IWORK ),
     $                            INFO )
C
                  END IF
C
               END IF
C
            ELSE IF( WNTVA ) THEN
C
               IF( WNTUN ) THEN
C
C                 Path 7t(N much larger than M, JOBU='N', JOBVT='A')
C                 N right singular vectors to be computed in VT and
C                 no left singular vectors to be computed
C
                  IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IR = 1
                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
C
C                       WORK(IR) is LDA by M
C
                        LDWRKR = LDA
                     ELSE
C
C                       WORK(IR) is M by M
C
                        LDWRKR = M
                     END IF
                     ITAU = IR + LDWRKR*M
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
C
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Copy L to WORK(IR), zeroing out above it
C
                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ),
     $                            LDWRKR )
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
     $                            WORK( IR+LDWRKR ), LDWRKR )
C
C                    Generate Q in VT
C                    (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
C
                     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
C
C                    Bidiagonalize L in WORK(IR)
C                    (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
C
                     CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S,
     $                            WORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in WORK(IR)
C                    (Workspace: need M*M+4*M-1,
C                                prefer M*M+3*M+(M-1)*NB)
C
                     CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing right
C                    singular vectors of L in WORK(IR)
C                    (Workspace: need M*M+BDSPAC)
C
                     CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
     $                            WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
     $                            WORK( IWORK ), INFO )
C
C                    Multiply right singular vectors of L in WORK(IR) by
C                    Q in VT, storing result in A
C                    (Workspace: need M*M)
C
                     CALL GGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
     $                           LDWRKR, VT, LDVT, ZERO, A, LDA )
C
C                    Copy right singular vectors of A from A to VT
C
                     CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (Workspace: need 2*M, prefer M+M*NB)
C
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (Workspace: need M+N, prefer M+N*NB)
C
                     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
C
C                    Zero out above L in A
C
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
     $                            LDA )
C
C                    Bidiagonalize L in A
C                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
C
                     CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply right bidiagonalizing vectors in A by Q
C                    in VT
C                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
C
                     CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
     $                            WORK( ITAUP ), VT, LDVT,
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing right
C                    singular vectors of A in VT
C                    (Workspace: need BDSPAC)
C
                     CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
     $                            LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
     $                            INFO )
C
                  END IF
C
               ELSE IF( WNTUO ) THEN
C
C                 Path 8t(N much larger than M, JOBU='O', JOBVT='A')
C                 N right singular vectors to be computed in VT and
C                 M left singular vectors to be overwritten on A
C
                  IF( LWORK.GE.2*M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
C
C                       WORK(IU) is LDA by M and WORK(IR) is LDA by M
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*M
                        LDWRKR = LDA
                     ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
C
C                       WORK(IU) is LDA by M and WORK(IR) is M by M
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*M
                        LDWRKR = M
                     ELSE
C
C                       WORK(IU) is M by M and WORK(IR) is M by M
C
                        LDWRKU = M
                        IR = IU + LDWRKU*M
                        LDWRKR = M
                     END IF
                     ITAU = IR + LDWRKR*M
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
C
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
C
                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to WORK(IU), zeroing out above it
C
                     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
C
C                    Bidiagonalize L in WORK(IU), copying result to
C                    WORK(IR)
C                    (Workspace: need 2*M*M+4*M,
C                                prefer 2*M*M+3*M+2*M*NB)
C
                     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 )
C
C                    Generate right bidiagonalizing vectors in WORK(IU)
C                    (Workspace: need 2*M*M+4*M-1,
C                                prefer 2*M*M+3*M+(M-1)*NB)
C
                     CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in WORK(IR)
C                    (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
C
                     CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of L in WORK(IR) and computing
C                    right singular vectors of L in WORK(IU)
C                    (Workspace: need 2*M*M+BDSPAC)
C
                     CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
     $                            WORK( IU ), LDWRKU, WORK( IR ),
     $                            LDWRKR, DUM, 1, WORK( IWORK ), INFO )
C
C                    Multiply right singular vectors of L in WORK(IU) by
C                    Q in VT, storing result in A
C                    (Workspace: need M*M)
C
                     CALL GGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
     $                           LDWRKU, VT, LDVT, ZERO, A, LDA )
C
C                    Copy right singular vectors of A from A to VT
C
                     CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
C
C                    Copy left singular vectors of A from WORK(IR) to A
C
                     CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
     $                            LDA )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (Workspace: need 2*M, prefer M+M*NB)
C
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (Workspace: need M+N, prefer M+N*NB)
C
                     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
C
C                    Zero out above L in A
C
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
     $                            LDA )
C
C                    Bidiagonalize L in A
C                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
C
                     CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply right bidiagonalizing vectors in A by Q
C                    in VT
C                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
C
                     CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
     $                            WORK( ITAUP ), VT, LDVT,
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in A
C                    (Workspace: need 4*M, prefer 3*M+M*NB)
C
                     CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in A and computing right
C                    singular vectors of A in VT
C                    (Workspace: need BDSPAC)
C
                     CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
     $                            LDVT, A, LDA, DUM, 1, WORK( IWORK ),
     $                            INFO )
C
                  END IF
C
               ELSE IF( WNTUAS ) THEN
C
C                 Path 9t(N much larger than M, JOBU='S' or 'A',
C                         JOBVT='A')
C                 N right singular vectors to be computed in VT and
C                 M left singular vectors to be computed in U
C
                  IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
C
C                       WORK(IU) is LDA by M
C
                        LDWRKU = LDA
                     ELSE
C
C                       WORK(IU) is M by M
C
                        LDWRKU = M
                     END IF
                     ITAU = IU + LDWRKU*M
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
C
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
C
                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to WORK(IU), zeroing out above it
C
                     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
C
C                    Bidiagonalize L in WORK(IU), copying result to U
C                    (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
C
                     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 )
C
C                    Generate right bidiagonalizing vectors in WORK(IU)
C                    (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
C
                     CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in U
C                    (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
C
                     CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of L in U and computing right
C                    singular vectors of L in WORK(IU)
C                    (Workspace: need M*M+BDSPAC)
C
                     CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
     $                            WORK( IU ), LDWRKU, U, LDU, DUM, 1,
     $                            WORK( IWORK ), INFO )
C
C                    Multiply right singular vectors of L in WORK(IU) by
C                    Q in VT, storing result in A
C                    (Workspace: need M*M)
C
                     CALL GGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
     $                           LDWRKU, VT, LDVT, ZERO, A, LDA )
C
C                    Copy right singular vectors of A from A to VT
C
                     CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (Workspace: need 2*M, prefer M+M*NB)
C
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (Workspace: need M+N, prefer M+N*NB)
C
                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to U, zeroing out above it
C
                     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
C
C                    Bidiagonalize L in U
C                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
C
                     CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply right bidiagonalizing vectors in U by Q
C                    in VT
C                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
C
                     CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
     $                            WORK( ITAUP ), VT, LDVT,
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in U
C                    (Workspace: need 4*M, prefer 3*M+M*NB)
C
                     CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U and computing right
C                    singular vectors of A in VT
C                    (Workspace: need BDSPAC)
C
                     CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
     $                            LDVT, U, LDU, DUM, 1, WORK( IWORK ),
     $                            INFO )
C
                  END IF
C
               END IF
C
            END IF
C
         ELSE
C
C           N .LT. MNTHR
C
C           Path 10t(N greater than M, but not much larger)
C           Reduce to bidiagonal form without LQ decomposition
C
            IE = 1
            ITAUQ = IE + M
            ITAUP = ITAUQ + M
            IWORK = ITAUP + M
C
C           Bidiagonalize A
C           (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
C
            CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
     $                   WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
     $                   IERR )
            IF( WNTUAS ) THEN
C
C              If left singular vectors desired in U, copy result to U
C              and generate left bidiagonalizing vectors in U
C              (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
C
               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
C
C              If right singular vectors desired in VT, copy result to
C              VT and generate right bidiagonalizing vectors in VT
C              (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB)
C
               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
C
C              If left singular vectors desired in A, generate left
C              bidiagonalizing vectors in A
C              (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
C
               CALL DORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTVO ) THEN
C
C              If right singular vectors desired in A, generate right
C              bidiagonalizing vectors in A
C              (Workspace: need 4*M, prefer 3*M+M*NB)
C
               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
C
C              Perform bidiagonal QR iteration, if desired, computing
C              left singular vectors in U and computing right singular
C              vectors in VT
C              (Workspace: need BDSPAC)
C
               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
C
C              Perform bidiagonal QR iteration, if desired, computing
C              left singular vectors in U and computing right singular
C              vectors in A
C              (Workspace: need BDSPAC)
C
               CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
     $                      U, LDU, DUM, 1, WORK( IWORK ), INFO )
            ELSE
C
C              Perform bidiagonal QR iteration, if desired, computing
C              left singular vectors in A and computing right singular
C              vectors in VT
C              (Workspace: need BDSPAC)
C
               CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
     $                      LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
            END IF
C
         END IF
C
      END IF
C
C     If DBDSQR failed to converge, copy unconverged superdiagonals
C     to WORK( 2:MINMN )
C
      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
C
C     Undo scaling if necessary
C
      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
C
C     Return optimal workspace in WORK(1)
C
      WORK( 1 ) = MAXWRK
C
      RETURN
      END
*Deck DGETF2
      SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     June 30, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      Real*8   A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  DGETF2 computes an LU factorization of a general m-by-n matrix A
C  using partial pivoting with row interchanges.
C
C  The factorization has the form
C     A = P * L * U
C  where P is a permutation matrix, L is lower triangular with unit
C  diagonal elements (lower trapezoidal if m > n), and U is upper
C  triangular (upper trapezoidal if m < n).
C
C  This is the right-looking Level 2 BLAS version of the algorithm.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the m by n matrix to be factored.
C          On exit, the factors L and U from the factorization
C          A = P*L*U; the unit diagonal elements of L are not stored.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  IPIV    (output) INTEGER array, dimension (min(M,N))
C          The pivot indices; for 1 <= i <= min(M,N), row i of the
C          matrix was interchanged with row IPIV(i).
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -k, the k-th argument had an illegal value
C          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
C               has been completed, but the factor U is exactly
C               singular, and division by zero will occur if it is used
C               to solve a system of equations.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      INTEGER            J, JP
C
C     Test the input parameters.
C
      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) Call GLBErr('DGetF2',Info)
C
C     Quick return if possible
C
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
C
      DO 10 J = 1, MIN( M, N )
C
C        Find pivot and test for singularity.
C
         JP = J - 1 + IGAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
C
C           Apply the interchange to columns 1:N.
C
            IF( JP.NE.J )
     $         CALL GSwap( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
C
C           Compute elements J+1:M of J-th column.
C
            IF( J.LT.M )
     $         CALL GScal( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
C
         ELSE IF( INFO.EQ.0 ) THEN
C
            INFO = J
         END IF
C
         IF( J.LT.MIN( M, N ) ) THEN
C
C           Update trailing submatrix.
C
            CALL GGER( 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
*Deck DGETRF
      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     March 31, 1993
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      Real*8   A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  DGETRF computes an LU factorization of a general M-by-N matrix A
C  using partial pivoting with row interchanges.
C
C  The factorization has the form
C     A = P * L * U
C  where P is a permutation matrix, L is lower triangular with unit
C  diagonal elements (lower trapezoidal if m > n), and U is upper
C  triangular (upper trapezoidal if m < n).
C
C  This is the right-looking Level 3 BLAS version of the algorithm.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the M-by-N matrix to be factored.
C          On exit, the factors L and U from the factorization
C          A = P*L*U; the unit diagonal elements of L are not stored.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  IPIV    (output) INTEGER array, dimension (min(M,N))
C          The pivot indices; for 1 <= i <= min(M,N), row i of the
C          matrix was interchanged with row IPIV(i).
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
C                has been completed, but the factor U is exactly
C                singular, and division by zero will occur if it is used
C                to solve a system of equations.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGETF2, DLASWP
C
C     Test the input parameters.
C
      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) Call GLBErr('DGetRF',Info)
C
C     Quick return if possible
C
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
C
C     Determine the block size for this environment.
C
      NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
C
C        Use unblocked code.
C
         CALL DGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
C
C        Use blocked code.
C
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
C
C           Factor diagonal and subdiagonal blocks and test for exact
C           singularity.
C
            CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
C
C           Adjust INFO and the pivot indices.
C
            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
C
C           Apply interchanges to columns 1:J-1.
C
            CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
C
            IF( J+JB.LE.N ) THEN
C
C              Apply interchanges to columns J+JB:N.
C
               CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
     $                      IPIV, 1 )
C
C              Compute block row of U.
C
               CALL GTRSM( '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
C
C                 Update trailing submatrix.
C
                  CALL GGEMM( '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
*Deck DGETRS
      SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     March 31, 1993
C
C     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      Real*8   A( LDA, * ), B( LDB, * )
C     ..
C
C  Purpose
C  =======
C
C  DGETRS solves a system of linear equations
C     A * X = B  or  A' * X = B
C  with a general N-by-N matrix A using the LU factorization computed
C  by DGETRF.
C
C  Arguments
C  =========
C
C  TRANS   (input) CHARACTER*1
C          Specifies the form of the system of equations:
C          = 'N':  A * X = B  (No transpose)
C          = 'T':  A'* X = B  (Transpose)
C          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  NRHS    (input) INTEGER
C          The number of right hand sides, i.e., the number of columns
C          of the matrix B.  NRHS >= 0.
C
C  A       (input) Real*8 array, dimension (LDA,N)
C          The factors L and U from the factorization A = P*L*U
C          as computed by DGETRF.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,N).
C
C  IPIV    (input) INTEGER array, dimension (N)
C          The pivot indices from DGETRF; for 1<=i<=N, row i of the
C          matrix was interchanged with row IPIV(i).
C
C  B       (input/output) Real*8 array, dimension (LDB,NRHS)
C          On entry, the right hand side matrix B.
C          On exit, the solution matrix X.
C
C  LDB     (input) INTEGER
C          The leading dimension of the array B.  LDB >= max(1,N).
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      LOGICAL            NOTRAN
      LOGICAL            GLSame
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLASWP
C
C     Test the input parameters.
C
      INFO = 0
      NOTRAN = GLSame( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.GLSame( TRANS, 'T' ) .AND. .NOT.
     $    GLSame( 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) Call GLBErr('DGetRS',Info)
      If(N.eq.0.or.NRHS.eq.0) RETURN
      IF( NOTRAN ) THEN
C
C        Solve A * X = B.
C
C        Apply row interchanges to the right hand sides.
C
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
C
C        Solve L*X = B, overwriting B with X.
C
         CALL GTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
C
C        Solve U*X = B, overwriting B with X.
C
         CALL GTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
     $               NRHS, ONE, A, LDA, B, LDB )
      ELSE
C
C        Solve A' * X = B.
C
C        Solve U'*X = B, overwriting B with X.
C
         CALL GTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
C
C        Solve L'*X = B, overwriting B with X.
C
         CALL GTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
     $               A, LDA, B, LDB )
C
C        Apply row interchanges to the solution vectors.
C
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
C
      RETURN
      END
*Deck DLABRD
      Subroutine DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
     $  LDY )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            LDA, LDX, LDY, M, N, NB
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), D( * ), E( * ), TAUP( * ),
     $                   TAUQ( * ), X( LDX, * ), Y( LDY, * )
C     ..
C
C  Purpose
C  =======
C
C  DLABRD reduces the first NB rows and columns of a real general
C  m by n matrix A to upper or lower bidiagonal form by an orthogonal
C  transformation Q' * A * P, and returns the matrices X and Y which
C  are needed to apply the transformation to the unreduced part of A.
C
C  If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
C  bidiagonal form.
C
C  This is an auxiliary routine called by DGEBRD
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows in the matrix A.
C
C  N       (input) INTEGER
C          The number of columns in the matrix A.
C
C  NB      (input) INTEGER
C          The number of leading rows and columns of A to be reduced.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the m by n general matrix to be reduced.
C          On exit, the first NB rows and columns of the matrix are
C          overwritten; the rest of the array is unchanged.
C          If m >= n, elements on and below the diagonal in the first NB
C            columns, with the array TAUQ, represent the orthogonal
C            matrix Q as a product of elementary reflectors; and
C            elements above the diagonal in the first NB rows, with the
C            array TAUP, represent the orthogonal matrix P as a product
C            of elementary reflectors.
C          If m < n, elements below the diagonal in the first NB
C            columns, with the array TAUQ, represent the orthogonal
C            matrix Q as a product of elementary reflectors, and
C            elements on and above the diagonal in the first NB rows,
C            with the array TAUP, represent the orthogonal matrix P as
C            a product of elementary reflectors.
C          See Further Details.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  D       (output) Real*8 array, dimension (NB)
C          The diagonal elements of the first NB rows and columns of
C          the reduced matrix.  D(i) = A(i,i).
C
C  E       (output) Real*8 array, dimension (NB)
C          The off-diagonal elements of the first NB rows and columns of
C          the reduced matrix.
C
C  TAUQ    (output) Real*8 array dimension (NB)
C          The scalar factors of the elementary reflectors which
C          represent the orthogonal matrix Q. See Further Details.
C
C  TAUP    (output) Real*8 array, dimension (NB)
C          The scalar factors of the elementary reflectors which
C          represent the orthogonal matrix P. See Further Details.
C
C  X       (output) Real*8 array, dimension (LDX,NB)
C          The m-by-nb matrix X required to update the unreduced part
C          of A.
C
C  LDX     (input) INTEGER
C          The leading dimension of the array X. LDX >= M.
C
C  Y       (output) Real*8 array, dimension (LDY,NB)
C          The n-by-nb matrix Y required to update the unreduced part
C          of A.
C
C  LDY     (output) INTEGER
C          The leading dimension of the array Y. LDY >= N.
C
C  Further Details
C  ===============
C
C  The matrices Q and P are represented as products of elementary
C  reflectors:
C
C     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb)
C
C  Each H(i) and G(i) has the form:
C
C     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
C
C  where tauq and taup are real scalars, and v and u are real vectors.
C
C  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
C  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
C  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
C
C  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
C  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
C  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
C
C  The elements of the vectors v and u together form the m-by-nb matrix
C  V and the nb-by-n matrix U' which are needed, with X and Y, to apply
C  the transformation to the unreduced part of the matrix, using a block
C  update of the form:  A := A - V*Y' - X*U'.
C
C  The contents of A on exit are illustrated by the following examples
C  with nb = 2:
C
C  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
C
C    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 )
C    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 )
C    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  )
C    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
C    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
C    (  v1  v2  a   a   a  )
C
C  where a denotes an element of the original matrix which is unchanged,
C  vi denotes an element of the vector defining H(i), and ui an element
C  of the vector defining G(i).
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I
C     ..
C     .. Executable Statements ..
C
C     Quick return if possible
C
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
C
      IF( M.GE.N ) THEN
C
C        Reduce to upper bidiagonal form
C
         DO 10 I = 1, NB
C
C           Update A(i:m,i)
C
            CALL GGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
     $                  LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
            CALL GGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
     $                  LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
C
C           Generate reflection Q(i) to annihilate A(i+1:m,i)
C
            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
C
C              Compute Y(i+1:n,i)
C
               CALL GGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ),
     $                     LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 )
               CALL GGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA,
     $                     A( I, I ), 1, ZERO, Y( 1, I ), 1 )
               CALL GGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
               CALL GGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX,
     $                     A( I, I ), 1, ZERO, Y( 1, I ), 1 )
               CALL GGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
     $                     LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
               CALL AScale( N-I, TAUQ( I ), Y( I+1, I ), Y( I+1, I ))
C
C              Update A(i,i+1:n)
C
               CALL GGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
     $                     LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
               CALL GGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
     $                     LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA )
C
C              Generate reflection P(i) to annihilate A(i,i+2:n)
C
               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
C
C              Compute X(i+1:m,i)
C
               CALL GGEMV( '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 GGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY,
     $                     A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
               CALL GGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL GGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
     $                     LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
               CALL GGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL AScale( M-I, TAUP( I ), X( I+1, I ), X( I+1, I ))
            END IF
   10    CONTINUE
      ELSE
C
C        Reduce to lower bidiagonal form
C
         DO 20 I = 1, NB
C
C           Update A(i,i:n)
C
            CALL GGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
     $                  LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
            CALL GGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA,
     $                  X( I, 1 ), LDX, ONE, A( I, I ), LDA )
C
C           Generate reflection P(i) to annihilate A(i,i+1:n)
C
            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
C
C              Compute X(i+1:m,i)
C
               CALL GGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
     $                     LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
               CALL GGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY,
     $                     A( I, I ), LDA, ZERO, X( 1, I ), 1 )
               CALL GGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL GGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
     $                     LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
               CALL GGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL AScale( M-I, TAUP( I ), X( I+1, I ), X( I+1, I ))
C
C              Update A(i+1:m,i)
C
               CALL GGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
     $                     LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
               CALL GGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
     $                     LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
C
C              Generate reflection Q(i) to annihilate A(i+2:m,i)
C
               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
C
C              Compute Y(i+1:n,i)
C
               CALL GGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ),
     $                     LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 )
               CALL GGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA,
     $                     A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
               CALL GGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
               CALL GGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX,
     $                     A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
               CALL GGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA,
     $                     Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
               CALL AScale( N-I, TAUQ( I ), Y( I+1, I ),Y( I+1, I ))
            END IF
   20    CONTINUE
      END IF
      RETURN
      END
*Deck DLACPY
      SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, LDB, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), B( LDB, * )
C     ..
C
C  Purpose
C  =======
C
C  DLACPY copies all or part of a two-dimensional matrix A to another
C  matrix B.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies the part of the matrix A to be copied to B.
C          = 'U':      Upper triangular part
C          = 'L':      Lower triangular part
C          Otherwise:  All of the matrix A
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input) Real*8 array, dimension (LDA,N)
C          The m by n matrix A.  If UPLO = 'U', only the upper triangle
C          or trapezoid is accessed; if UPLO = 'L', only the lower
C          triangle or trapezoid is accessed.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  B       (output) Real*8 array, dimension (LDB,N)
C          On exit, B = A in the locations specified by UPLO.
C
C  LDB     (input) INTEGER
C          The leading dimension of the array B.  LDB >= max(1,M).
C
C  =====================================================================
C
C     .. Local Scalars ..
      INTEGER            I, J
      Logical GLSame
C     ..
C     .. Executable Statements ..
C
      IF( GLSame( 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( GLSame( 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
*Deck DLADIV
      SUBROUTINE DLADIV( A, B, C, D, P, Q )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      Real*8   A, B, C, D, P, Q
C     ..
C
C  Purpose
C  =======
C
C  DLADIV performs complex division in  real arithmetic
C
C                        a + i*b
C             p + i*q = ---------
C                        c + i*d
C
C  The algorithm is due to Robert L. Smith and can be found
C  in D. Knuth, The art of Computer Programming, Vol.2, p.195
C
C  Arguments
C  =========
C
C  A       (input) DOUBLE PRECISION
C  B       (input) DOUBLE PRECISION
C  C       (input) DOUBLE PRECISION
C  D       (input) DOUBLE PRECISION
C          The scalars a, b, c, and d in the above expression.
C
C  P       (output) DOUBLE PRECISION
C  Q       (output) DOUBLE PRECISION
C          The scalars p and q in the above expression.
C
C  =====================================================================
C
C     .. Local Scalars ..
      Real*8   E, F
C
      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
*Deck DLAE2
      SUBROUTINE DLAE2( A, B, C, RT1, RT2 )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      Real*8   A, B, C, RT1, RT2
C     ..
C
C  Purpose
C  =======
C
C  DLAE2  computes the eigenvalues of a 2-by-2 symmetric matrix
C     [  A   B  ]
C     [  B   C  ].
C  On return, RT1 is the eigenvalue of larger absolute value, and RT2
C  is the eigenvalue of smaller absolute value.
C
C  Arguments
C  =========
C
C  A       (input) Real*8
C          The (1,1) element of the 2-by-2 matrix.
C
C  B       (input) Real*8
C          The (1,2) and (2,1) elements of the 2-by-2 matrix.
C
C  C       (input) Real*8
C          The (2,2) element of the 2-by-2 matrix.
C
C  RT1     (output) Real*8
C          The eigenvalue of larger absolute value.
C
C  RT2     (output) Real*8
C          The eigenvalue of smaller absolute value.
C
C  Further Details
C  ===============
C
C  RT1 is accurate to a few ulps barring over/underflow.
C
C  RT2 may be inaccurate if there is massive cancellation in the
C  determinant A*C-B*B; higher precision or correctly rounded or
C  correctly truncated arithmetic would be needed to compute RT2
C  accurately in all cases.
C
C  Overflow is possible only if RT1 is within a factor of 5 of overflow.
C  Underflow is harmless if the input data is 0 or exceeds
C     underflow_threshold / macheps.
C
C =====================================================================
C
C     .. Parameters ..
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D0 )
      Real*8   TWO
      PARAMETER          ( TWO = 2.0D0 )
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      Real*8   HALF
      PARAMETER          ( HALF = 0.5D0 )
C     ..
C     .. Local Scalars ..
      Real*8   AB, ACMN, ACMX, ADF, DF, RT, SM, TB
C     ..
C     .. Executable Statements ..
C
C     Compute the eigenvalues
C
      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
C
C        Includes case AB=ADF=0
C
         RT = AB*SQRT( TWO )
      END IF
      IF( SM.LT.ZERO ) THEN
         RT1 = HALF*( SM-RT )
C
C        Order of execution important.
C        To get fully accurate smaller eigenvalue,
C        next line needs to be executed in higher precision.
C
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE IF( SM.GT.ZERO ) THEN
         RT1 = HALF*( SM+RT )
C
C        Order of execution important.
C        To get fully accurate smaller eigenvalue,
C        next line needs to be executed in higher precision.
C
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE
C
C        Includes case RT1 = RT2 = 0
C
         RT1 = HALF*RT
         RT2 = -HALF*RT
      END IF
      RETURN
      END
*Deck DLAEV2
      SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      Real*8   A, B, C, CS1, RT1, RT2, SN1
C     ..
C
C  Purpose
C  =======
C
C  DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
C     [  A   B  ]
C     [  B   C  ].
C  On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
C  eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
C  eigenvector for RT1, giving the decomposition
C
C     [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ]
C     [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ].
C
C  Arguments
C  =========
C
C  A       (input) Real*8
C          The (1,1) element of the 2-by-2 matrix.
C
C  B       (input) Real*8
C          The (1,2) element and the conjugate of the (2,1) element of
C          the 2-by-2 matrix.
C
C  C       (input) Real*8
C          The (2,2) element of the 2-by-2 matrix.
C
C  RT1     (output) Real*8
C          The eigenvalue of larger absolute value.
C
C  RT2     (output) Real*8
C          The eigenvalue of smaller absolute value.
C
C  CS1     (output) Real*8
C  SN1     (output) Real*8
C          The vector (CS1, SN1) is a unit right eigenvector for RT1.
C
C  Further Details
C  ===============
C
C  RT1 is accurate to a few ulps barring over/underflow.
C
C  RT2 may be inaccurate if there is massive cancellation in the
C  determinant A*C-B*B; higher precision or correctly rounded or
C  correctly truncated arithmetic would be needed to compute RT2
C  accurately in all cases.
C
C  CS1 and SN1 are accurate to a few ulps barring over/underflow.
C
C  Overflow is possible only if RT1 is within a factor of 5 of overflow.
C  Underflow is harmless if the input data is 0 or exceeds
C     underflow_threshold / macheps.
C
C =====================================================================
C
C     .. Parameters ..
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D0 )
      Real*8   TWO
      PARAMETER          ( TWO = 2.0D0 )
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      Real*8   HALF
      PARAMETER          ( HALF = 0.5D0 )
C     ..
C     .. Local Scalars ..
      INTEGER            SGN1, SGN2
      Real*8   AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
     $                   TB, TN
C     ..
C     .. Executable Statements ..
C
C     Compute the eigenvalues
C
      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
C
C        Includes case AB=ADF=0
C
         RT = AB*SQRT( TWO )
      END IF
      IF( SM.LT.ZERO ) THEN
         RT1 = HALF*( SM-RT )
         SGN1 = -1
C
C        Order of execution important.
C        To get fully accurate smaller eigenvalue,
C        next line needs to be executed in higher precision.
C
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE IF( SM.GT.ZERO ) THEN
         RT1 = HALF*( SM+RT )
         SGN1 = 1
C
C        Order of execution important.
C        To get fully accurate smaller eigenvalue,
C        next line needs to be executed in higher precision.
C
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE
C
C        Includes case RT1 = RT2 = 0
C
         RT1 = HALF*RT
         RT2 = -HALF*RT
         SGN1 = 1
      END IF
C
C     Compute the eigenvector
C
      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
*Deck DLAMC1
      SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      LOGICAL            IEEE1, RND
      INTEGER            BETA, T
C     ..
C
C  Purpose
C  =======
C
C  DLAMC1 determines the machine parameters given by BETA, T, RND, and
C  IEEE1.
C
C  Arguments
C  =========
C
C  BETA    (output) INTEGER
C          The base of the machine.
C
C  T       (output) INTEGER
C          The number of ( BETA ) digits in the mantissa.
C
C  RND     (output) LOGICAL
C          Specifies whether proper rounding  ( RND = .TRUE. )  or
C          chopping  ( RND = .FALSE. )  occurs in addition. This may not
C          be a reliable guide to the way in which the machine performs
C          its arithmetic.
C
C  IEEE1   (output) LOGICAL
C          Specifies whether rounding appears to be done in the IEEE
C          'round to nearest' style.
C
C  Further Details
C  ===============
C
C  The routine is based on the routine  ENVRON  by Malcolm and
C  incorporates suggestions by Gentleman and Marovich. See
C
C     Malcolm M. A. (1972) Algorithms to reveal properties of
C        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
C
C     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
C        that reveal properties of floating point arithmetic units.
C        Comms. of the ACM, 17, 276-277.
C
C =====================================================================
C
C     .. Local Scalars ..
      LOGICAL            FIRST, LIEEE1, LRND
      INTEGER            LBETA, LT
      Real*8   A, B, C, F, ONE, QTR, SAVEC, T1, T2
C     ..
C     .. Save statement ..
      SAVE               FIRST, LIEEE1, LBETA, LRND, LT
C     ..
C     .. Data statements ..
      DATA               FIRST / .TRUE. /
C     ..
C     .. Executable Statements ..
C
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ONE = 1
C
C        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
C        IEEE1, T and RND.
C
C        Throughout this routine  we use the function  DLAMC3  to ensure
C        that relevant values are  stored and not held in registers,  or
C        are not affected by optimizers.
C
C        Compute  a = 2.0**m  with the  smallest positive integer m such
C        that
C
C           fl( a + 1.0 ) = a.
C
         A = 1
         C = 1
C
C+       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
C+       END WHILE
C
C        Now compute  b = 2.0**m  with the smallest positive integer m
C        such that
C
C           fl( a + b ) .gt. a.
C
         B = 1
         C = DLAMC3( A, B )
C
C+       WHILE( C.EQ.A )LOOP
   20    CONTINUE
         IF( C.EQ.A ) THEN
            B = 2*B
            C = DLAMC3( A, B )
            GO TO 20
         END IF
C+       END WHILE
C
C        Now compute the base.  a and c  are neighbouring floating point
C        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
C        their difference is beta. Adding 0.25 to c is to ensure that it
C        is truncated to beta and not ( beta - 1 ).
C
         QTR = ONE / 4
         SAVEC = C
         C = DLAMC3( C, -A )
         LBETA = C + QTR
C
C        Now determine whether rounding or chopping occurs,  by adding a
C        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
C
         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.
C
C        Try and decide whether rounding is done in the  IEEE  'round to
C        nearest' style. B/2 is half a unit in the last place of the two
C        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
C        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
C        A, but adding B/2 to SAVEC should change SAVEC.
C
         T1 = DLAMC3( B / 2, A )
         T2 = DLAMC3( B / 2, SAVEC )
         LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
C
C        Now find  the  mantissa, t.  It should  be the  integer part of
C        log to the base beta of a,  however it is safer to determine  t
C        by powering.  So we find t as the smallest positive integer for
C        which
C
C           fl( beta**t + 1.0 ) = 1.0.
C
         LT = 0
         A = 1
         C = 1
C
C+       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
C+       END WHILE
C
      END IF
C
      BETA = LBETA
      T = LT
      RND = LRND
      IEEE1 = LIEEE1
      RETURN
      END
*Deck DLAMC2
      SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      LOGICAL            RND
      INTEGER            BETA, EMAX, EMIN, T
      Real*8   EPS, RMAX, RMIN
C     ..
C
C  Purpose
C  =======
C
C  DLAMC2 determines the machine parameters specified in its argument
C  list.
C
C  Arguments
C  =========
C
C  BETA    (output) INTEGER
C          The base of the machine.
C
C  T       (output) INTEGER
C          The number of ( BETA ) digits in the mantissa.
C
C  RND     (output) LOGICAL
C          Specifies whether proper rounding  ( RND = .TRUE. )  or
C          chopping  ( RND = .FALSE. )  occurs in addition. This may not
C          be a reliable guide to the way in which the machine performs
C          its arithmetic.
C
C  EPS     (output) Real*8
C          The smallest positive number such that
C
C             fl( 1.0 - EPS ) .LT. 1.0,
C
C          where fl denotes the computed value.
C
C  EMIN    (output) INTEGER
C          The minimum exponent before (gradual) underflow occurs.
C
C  RMIN    (output) Real*8
C          The smallest normalized number for the machine, given by
C          BASE**( EMIN - 1 ), where  BASE  is the floating point value
C          of BETA.
C
C  EMAX    (output) INTEGER
C          The maximum exponent before overflow occurs.
C
C  RMAX    (output) Real*8
C          The largest positive number for the machine, given by
C          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
C          value of BETA.
C
C  Further Details
C  ===============
C
C  The computation of  EPS  is based on a routine PARANOIA by
C  W. Kahan of the University of California at Berkeley.
C
C =====================================================================
C
C     .. Local Scalars ..
      LOGICAL            FIRST, IEEE, LIEEE1, LRND
      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
     $                   NGNMIN, NGPMIN
      Real*8   A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
     $                   SIXTH, SMALL, THIRD, TWO, ZERO
C     ..
C     .. Save statement ..
      SAVE               FIRST, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
     $                   LRMIN, LT
C     ..
C     .. Data statements ..
      DATA               FIRST / .TRUE. /
C     ..
C     .. Executable Statements ..
C
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ZERO = 0
         ONE = 1
         TWO = 2
C
C        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of
C        BETA, T, RND, EPS, EMIN and RMIN.
C
C        Throughout this routine  we use the function  DLAMC3  to ensure
C        that relevant values are stored  and not held in registers,  or
C        are not affected by optimizers.
C
C        DLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1.
C
         CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
C
C        Start to find EPS.
C
         B = LBETA
         A = B**( -LT )
         LEPS = A
C
C        Try some tricks to see whether or not this is the correct  EPS.
C
         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
C
         LEPS = 1
C
C+       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
C+       END WHILE
C
         IF( A.LT.LEPS )
     $      LEPS = A
C
C        Computation of EPS complete.
C
C        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)).
C        Keep dividing  A by BETA until (gradual) underflow occurs. This
C        is detected when we cannot recover the previous A.
C
         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.
C
         IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
            IF( NGPMIN.EQ.GPMIN ) THEN
               LEMIN = NGPMIN
C            ( Non twos-complement machines, no gradual underflow;
C              e.g.,  VAX )
            ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
               LEMIN = NGPMIN - 1 + LT
               IEEE = .TRUE.
C            ( Non twos-complement machines, with gradual underflow;
C              e.g., IEEE standard followers )
            ELSE
               LEMIN = MIN( NGPMIN, GPMIN )
C            ( A guess; no known machine )
C              IWARN = .TRUE.
            END IF
C
         ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
            IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN )
C            ( Twos-complement machines, no gradual underflow;
C              e.g., CYBER 205 )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
C            ( A guess; no known machine )
C              IWARN = .TRUE.
            END IF
C
         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
C            ( Twos-complement machines with gradual underflow;
C              no known machine )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
C            ( A guess; no known machine )
C              IWARN = .TRUE.
            END IF
C
         ELSE
            LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
C         ( A guess; no known machine )
C           IWARN = .TRUE.
         END IF
C**
C Comment out this if block if EMIN is ok
C        IF( IWARN ) THEN
C           FIRST = .TRUE.
C           WRITE( 6, FMT = 9999 )LEMIN
C        END IF
C**
C
C        Assume IEEE arithmetic if we found denormalised  numbers above,
C        or if arithmetic seems to round in the  IEEE style,  determined
C        in routine DLAMC1. A true IEEE machine should have both  things
C        true; however, faulty machines may have one or the other.
C
         IEEE = IEEE .OR. LIEEE1
C
C        Compute  RMIN by successive division by  BETA. We could compute
C        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
C        this computation.
C
         LRMIN = 1
         DO 30 I = 1, 1 - LEMIN
            LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
   30    CONTINUE
C
C        Finally, call DLAMC5 to compute EMAX and RMAX.
C
         CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
      END IF
C
      BETA = LBETA
      T = LT
      RND = LRND
      EPS = LEPS
      EMIN = LEMIN
      RMIN = LRMIN
      EMAX = LEMAX
      RMAX = LRMAX
C
      RETURN
C
 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
*Deck DLAMC3
      FUNCTION DLAMC3( A, B )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      Real*8   A, B
C     ..
C
C  Purpose
C  =======
C
C  DLAMC3  is intended to force  A  and  B  to be stored prior to doing
C  the addition of  A  and  B ,  for use in situations where optimizers
C  might hold one of these in a register.
C
C  Arguments
C  =========
C
C  A, B    (input) Real*8
C          The values A and B.
C
C =====================================================================
C
C     .. Executable Statements ..
C
      DLAMC3 = A + B
C
      RETURN
      END
*Deck DLAMC4
      SUBROUTINE DLAMC4( EMIN, START, BASE )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      INTEGER            BASE, EMIN
      Real*8   START
C     ..
C
C  Purpose
C  =======
C
C  DLAMC4 is a service routine for DLAMC2.
C
C  Arguments
C  =========
C
C  EMIN    (output) EMIN
C          The minimum exponent before (gradual) underflow, computed by
C          setting A = START and dividing by BASE until the previous A
C          can not be recovered.
C
C  START   (input) Real*8
C          The starting point for determining EMIN.
C
C  BASE    (input) INTEGER
C          The base of the machine.
C
C =====================================================================
C
C     .. Local Scalars ..
      INTEGER            I
      Real*8   A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
C     ..
C     .. Executable Statements ..
C
      A = START
      ONE = 1
      RBASE = ONE / BASE
      ZERO = 0
      EMIN = 1
      B1 = DLAMC3( A*RBASE, ZERO )
      C1 = A
      C2 = A
      D1 = A
      D2 = A
C+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
C    $       ( 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
C+    END WHILE
      RETURN
      END
*Deck DLAMC5
      SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            BETA, EMAX, EMIN, P
      Real*8   RMAX
C     ..
C
C  Purpose
C  =======
C
C  DLAMC5 attempts to compute RMAX, the largest machine floating-point
C  number, without overflow.  It assumes that EMAX + abs(EMIN) sum
C  approximately to a power of 2.  It will fail on machines where this
C  assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
C  EMAX = 28718).  It will also fail if the value supplied for EMIN is
C  too large (i.e. too close to zero), probably with overflow.
C
C  Arguments
C  =========
C
C  BETA    (input) INTEGER
C          The base of floating-point arithmetic.
C
C  P       (input) INTEGER
C          The number of base BETA digits in the mantissa of a
C          floating-point value.
C
C  EMIN    (input) INTEGER
C          The minimum exponent before (gradual) underflow.
C
C  IEEE    (input) LOGICAL
C          A logical flag specifying whether or not the arithmetic
C          system is thought to comply with the IEEE standard.
C
C  EMAX    (output) INTEGER
C          The largest exponent before overflow
C
C  RMAX    (output) Real*8
C          The largest machine floating-point number.
C
C =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     ..
C     .. Local Scalars ..
      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
      Real*8   OLDY, RECBAS, Y, Z
C     ..
C     .. Executable Statements ..
C
C     First compute LEXP and UEXP, two powers of 2 that bound
C     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
C     approximately to the bound that is closest to abs(EMIN).
C     (EMAX is the exponent of the required number RMAX).
C
      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
C
C     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
C     than or equal to EMIN. EXBITS is the number of bits needed to
C     store the exponent.
C
      IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
         EXPSUM = 2*LEXP
      ELSE
         EXPSUM = 2*UEXP
      END IF
C
C     EXPSUM is the exponent range, approximately equal to
C     EMAX - EMIN + 1 .
C
      EMAX = EXPSUM + EMIN - 1
      NBITS = 1 + EXBITS + P
C
C     NBITS is the total number of bits needed to store a
C     floating-point number.
C
      IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
C
C        Either there are an odd number of bits used to store a
C        floating-point number, which is unlikely, or some bits are
C        not used in the representation of numbers, which is possible,
C        (e.g. Cray machines) or the mantissa has an implicit bit,
C        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
C        most likely. We have to assume the last alternative.
C        If this is true, then we need to reduce EMAX by one because
C        there must be some way of representing zero in an implicit-bit
C        system. On machines like Cray, we are reducing EMAX by one
C        unnecessarily.
C
         EMAX = EMAX - 1
      END IF
C
      IF( IEEE ) THEN
C
C        Assume we are on an IEEE machine which reserves one exponent
C        for infinity and NaN.
C
         EMAX = EMAX - 1
      END IF
C
C     Now create RMAX, the largest machine number, which should
C     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
C
C     First compute 1.0 - BETA**(-P), being careful that the
C     result is less than 1.0 .
C
      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
C
C     Now multiply by BETA**EMAX to get RMAX.
C
      DO 30 I = 1, EMAX
         Y = DLAMC3( Y*BETA, ZERO )
   30 CONTINUE
C
      RMAX = Y
      RETURN
      END
*Deck DLANGE
      FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            LDA, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DLANGE  returns the value of the one norm,  or the Frobenius norm, or
C  the  infinity norm,  or the  element of  largest absolute value  of a
C  real matrix A.
C
C  Description
C  ===========
C
C  DLANGE returns the value
C
C     DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
C              (
C              ( norm1(A),         NORM = '1', 'O' or 'o'
C              (
C              ( normI(A),         NORM = 'I' or 'i'
C              (
C              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
C
C  where  norm1  denotes the  one norm of a matrix (maximum column sum),
C  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
C  normF  denotes the  Frobenius norm of a matrix (square root of sum of
C  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
C
C  Arguments
C  =========
C
C  NORM    (input) CHARACTER*1
C          Specifies the value to be returned in DLANGE as described
C          above.
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.  When M = 0,
C          DLANGE is set to zero.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.  When N = 0,
C          DLANGE is set to zero.
C
C  A       (input) Real*8 array, dimension (LDA,N)
C          The m by n matrix A.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(M,1).
C
C  WORK    (workspace) Real*8 array, dimension (LWORK),
C          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
C          referenced.
C
C =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, J
      Real*8   SCALE, SUM, VALUE
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
      IF( MIN( M, N ).EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( GLSame( NORM, 'M' ) ) THEN
C
C        Find max(abs(A(i,j))).
C
         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( ( GLSame( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
C
C        Find norm1(A).
C
         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( GLSame( NORM, 'I' ) ) THEN
C
C        Find normI(A).
C
         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((GLSame(NORM,'F')).OR.(GLSame(NORM,'E'))) THEN
C
C        Find normF(A).
C
         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
*Deck DLANSP
      Real*8 FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          NORM, UPLO
      INTEGER            N
C     ..
C     .. Array Arguments ..
      Real*8   AP( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DLANSP  returns the value of the one norm,  or the Frobenius norm, or
C  the  infinity norm,  or the  element of  largest absolute value  of a
C  real symmetric matrix A,  supplied in packed form.
C
C  Description
C  ===========
C
C  DLANSP returns the value
C
C     DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
C              (
C              ( norm1(A),         NORM = '1', 'O' or 'o'
C              (
C              ( normI(A),         NORM = 'I' or 'i'
C              (
C              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
C
C  where  norm1  denotes the  one norm of a matrix (maximum column sum),
C  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
C  normF  denotes the  Frobenius norm of a matrix (square root of sum of
C  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
C
C  Arguments
C  =========
C
C  NORM    (input) CHARACTER*1
C          Specifies the value to be returned in DLANSP as described
C          above.
C
C  UPLO    (input) CHARACTER*1
C          Specifies whether the upper or lower triangular part of the
C          symmetric matrix A is supplied.
C          = 'U':  Upper triangular part of A is supplied
C          = 'L':  Lower triangular part of A is supplied
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.  When N = 0, DLANSP is
C          set to zero.
C
C  AP      (input) Real*8 array, dimension (N*(N+1)/2)
C          The upper or lower triangle of the symmetric matrix A, packed
C          columnwise in a linear array.  The j-th column of A is stored
C          in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
C
C  WORK    (workspace) Real*8 array, dimension (LWORK),
C          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
C          WORK is not referenced.
C
C =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, J, K
      Real*8   ABSA, SCALE, SUM, VALUE
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
      IF( N.EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( GLSame( NORM, 'M' ) ) THEN
C
C        Find max(abs(A(i,j))).
C
         VALUE = ZERO
         IF( GLSame( 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( ( GLSame( NORM, 'I' ) ) .OR. ( GLSame( NORM, 'O' ) ) .OR.
     $         ( NORM.EQ.'1' ) ) THEN
C
C        Find normI(A) ( = norm1(A), since A is symmetric).
C
         VALUE = ZERO
         K = 1
         IF( GLSame( 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((GLSame(NORM,'F')).OR.(GLSame(NORM,'E'))) THEN
C
C        Find normF(A).
C
         SCALE = ZERO
         SUM = ONE
         K = 2
         IF( GLSame( 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( GLSame( UPLO, 'U' ) ) THEN
               K = K + I + 1
            ELSE
               K = K + N - I + 1
            END IF
  130    CONTINUE
         VALUE = SCALE*SQRT( SUM )
      END IF
C
      DLANSP = VALUE
      RETURN
      END
*Deck DLANST
      FUNCTION DLANST( NORM, N, D, E )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            N
C     ..
C     .. Array Arguments ..
      Real*8   D( * ), E( * )
C     ..
C
C  Purpose
C  =======
C
C  DLANST  returns the value of the one norm,  or the Frobenius norm, or
C  the  infinity norm,  or the  element of  largest absolute value  of a
C  real symmetric tridiagonal matrix A.
C
C  Description
C  ===========
C
C  DLANST returns the value
C
C     DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'
C              (
C              ( norm1(A),         NORM = '1', 'O' or 'o'
C              (
C              ( normI(A),         NORM = 'I' or 'i'
C              (
C              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
C
C  where  norm1  denotes the  one norm of a matrix (maximum column sum),
C  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
C  normF  denotes the  Frobenius norm of a matrix (square root of sum of
C  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
C
C  Arguments
C  =========
C
C  NORM    (input) CHARACTER*1
C          Specifies the value to be returned in DLANST as described
C          above.
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.  When N = 0, DLANST is
C          set to zero.
C
C  D       (input) Real*8 array, dimension (N)
C          The diagonal elements of A.
C
C  E       (input) Real*8 array, dimension (N-1)
C          The (n-1) sub-diagonal or super-diagonal elements of A.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I
      Real*8   ANORM, SCALE, SUM
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
      IF( N.LE.0 ) THEN
         ANORM = ZERO
      ELSE IF( GLSame( NORM, 'M' ) ) THEN
C
C        Find max(abs(A(i,j))).
C
         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( GLSame( NORM, 'O' ) .OR. NORM.EQ.'1' .OR.
     $         GLSame( NORM, 'I' ) ) THEN
C
C        Find norm1(A).
C
         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((GLSame(NORM,'F')).OR.(GLSame(NORM,'E'))) THEN
C
C        Find normF(A).
C
         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
C
      DLANST = ANORM
      RETURN
      END
*Deck DLAPY2
      FUNCTION DLAPY2( X, Y )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      Real*8   X, Y
C     ..
C
C  Purpose
C  =======
C
C  DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
C  overflow.
C
C  Arguments
C  =========
C
C  X       (input) Real*8
C  Y       (input) Real*8
C          X and Y specify the values x and y.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D0 )
C     ..
C     .. Local Scalars ..
      Real*8   W, XABS, YABS, Z
C     ..
C     .. Executable Statements ..
C
      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
*Deck DLAPY3
      FUNCTION DLAPY3( X, Y, Z )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      Real*8   X, Y, Z
C     ..
C
C  Purpose
C  =======
C
C  DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
C  unnecessary overflow.
C
C  Arguments
C  =========
C
C  X       (input) DOUBLE PRECISION
C  Y       (input) DOUBLE PRECISION
C  Z       (input) DOUBLE PRECISION
C          X, Y and Z specify the values x, y and z.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
C     ..
C     .. Local Scalars ..
      Real*8   W, XABS, YABS, ZABS
C
      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
*Deck DLARF
      SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER*(*)      SIDE
      INTEGER            INCV, LDC, M, N
      Real*8   TAU
C     ..
C     .. Array Arguments ..
      Real*8   C( LDC, * ), V( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DLARF applies a real elementary reflector H to a real m by n matrix
C  C, from either the left or the right. H is represented in the form
C
C        H = I - tau * v * v'
C
C  where tau is a real scalar and v is a real vector.
C
C  If tau = 0, then H is taken to be the unit matrix.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': form  H * C
C          = 'R': form  C * H
C
C  M       (input) INTEGER
C          The number of rows of the matrix C.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C.
C
C  V       (input) Real*8 array, dimension
C                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
C                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
C          The vector v in the representation of H. V is not used if
C          TAU = 0.
C
C  INCV    (input) INTEGER
C          The increment between elements of v. INCV <> 0.
C
C  TAU     (input) Real*8
C          The value tau in the representation of H.
C
C  C       (input/output) Real*8 array, dimension (LDC,N)
C          On entry, the m by n matrix C.
C          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
C          or C * H if SIDE = 'R'.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace) Real*8 array, dimension
C                         (N) if SIDE = 'L'
C                      or (M) if SIDE = 'R'
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
      IF( GLSame( SIDE, 'L' ) ) THEN
C
C        Form  H * C
C
         IF( TAU.NE.ZERO ) THEN
C
C           w := C' * v
C
            CALL GGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO,
     $                  WORK, 1 )
C
C           C := C - v * w'
C
            CALL GGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
         END IF
      ELSE
C
C        Form  C * H
C
         IF( TAU.NE.ZERO ) THEN
C
C           w := C * v
C
            CALL GGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
     $                  ZERO, WORK, 1 )
C
C           C := C - w * v'
C
            CALL GGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
         END IF
      END IF
      RETURN
      END
*Deck DLARFB
      SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
     $                   T, LDT, C, LDC, WORK, LDWORK )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER*(*)      DIRECT, SIDE, STOREV, TRANS
      INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
C     ..
C     .. Array Arguments ..
      Real*8   C( LDC, * ), T( LDT, * ), V( LDV, * ),
     $                   WORK( LDWORK, * )
C     ..
C
C  Purpose
C  =======
C
C  DLARFB applies a real block reflector H or its transpose H' to a
C  real m by n matrix C, from either the left or the right.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': apply H or H' from the Left
C          = 'R': apply H or H' from the Right
C
C  TRANS   (input) CHARACTER*1
C          = 'N': apply H (No transpose)
C          = 'T': apply H' (Transpose)
C
C  DIRECT  (input) CHARACTER*1
C          Indicates how H is formed from a product of elementary
C          reflectors
C          = 'F': H = H(1) H(2) . . . H(k) (Forward)
C          = 'B': H = H(k) . . . H(2) H(1) (Backward)
C
C  STOREV  (input) CHARACTER*1
C          Indicates how the vectors which define the elementary
C          reflectors are stored:
C          = 'C': Columnwise
C          = 'R': Rowwise
C
C  M       (input) INTEGER
C          The number of rows of the matrix C.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C.
C
C  K       (input) INTEGER
C          The order of the matrix T (= the number of elementary
C          reflectors whose product defines the block reflector).
C
C  V       (input) Real*8 array, dimension
C                                (LDV,K) if STOREV = 'C'
C                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
C                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
C          The matrix V. See further details.
C
C  LDV     (input) INTEGER
C          The leading dimension of the array V.
C          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
C          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
C          if STOREV = 'R', LDV >= K.
C
C  T       (input) Real*8 array, dimension (LDT,K)
C          The triangular k by k matrix T in the representation of the
C          block reflector.
C
C  LDT     (input) INTEGER
C          The leading dimension of the array T. LDT >= K.
C
C  C       (input/output) Real*8 array, dimension (LDC,N)
C          On entry, the m by n matrix C.
C          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDA >= max(1,M).
C
C  WORK    (workspace) Real*8 array, dimension (LDWORK,K)
C
C  LDWORK  (input) INTEGER
C          The leading dimension of the array WORK.
C          If SIDE = 'L', LDWORK >= max(1,N);
C          if SIDE = 'R', LDWORK >= max(1,M).
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      CHARACTER          TRANST
      Logical GLSame
      INTEGER            I, J
C     ..
C     .. Executable Statements ..
C
C     Quick return if possible
C
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
C
      IF( GLSame( TRANS, 'N' ) ) THEN
         TRANST = 'T'
      ELSE
         TRANST = 'N'
      END IF
C
      IF( GLSame( STOREV, 'C' ) ) THEN
C
         IF( GLSame( DIRECT, 'F' ) ) THEN
C
C           Let  V =  ( V1 )    (first K rows)
C                     ( V2 )
C           where  V1  is unit lower triangular.
C
            IF( GLSame( SIDE, 'L' ) ) THEN
C
C              Form  H * C  or  H' * C  where  C = ( C1 )
C                                                  ( C2 )
C
C              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
C
C              W := C1'
C
               DO 10 J = 1, K
                  CALL GCopy( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
   10          CONTINUE
C
C              W := W * V1
C
               CALL GTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
     $                     K, ONE, V, LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
C
C                 W := W + C2'*V2
C
                  CALL GGEMM( 'Transpose', 'No transpose', N, K, M-K,
     $                        ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
     $                        ONE, WORK, LDWORK )
               END IF
C
C              W := W * T'  or  W * T
C
               CALL GTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - V * W'
C
               IF( M.GT.K ) THEN
C
C                 C2 := C2 - V2 * W'
C
                  CALL GGEMM( 'No transpose', 'Transpose', M-K, N, K,
     $                        -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
     $                        C( K+1, 1 ), LDC )
               END IF
C
C              W := W * V1'
C
               CALL GTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
     $                     ONE, V, LDV, WORK, LDWORK )
C
C              C1 := C1 - W'
C
               DO 30 J = 1, K
                  DO 20 I = 1, N
                     C( J, I ) = C( J, I ) - WORK( I, J )
   20             CONTINUE
   30          CONTINUE
C
            ELSE IF( GLSame( SIDE, 'R' ) ) THEN
C
C              Form  C * H  or  C * H'  where  C = ( C1  C2 )
C
C              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
C
C              W := C1
C
               DO 40 J = 1, K
                  CALL GCopy( M, C( 1, J ), 1, WORK( 1, J ), 1 )
   40          CONTINUE
C
C              W := W * V1
C
               CALL GTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
     $                     K, ONE, V, LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
C
C                 W := W + C2 * V2
C
                  CALL GGEMM( 'No transpose', 'No transpose', M, K, N-K,
     $                        ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
     $                        ONE, WORK, LDWORK )
               END IF
C
C              W := W * T  or  W * T'
C
               CALL GTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - W * V'
C
               IF( N.GT.K ) THEN
C
C                 C2 := C2 - W * V2'
C
                  CALL GGEMM( 'No transpose', 'Transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
     $                        C( 1, K+1 ), LDC )
               END IF
C
C              W := W * V1'
C
               CALL GTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
     $                     ONE, V, LDV, WORK, LDWORK )
C
C              C1 := C1 - W
C
               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
C
         ELSE
C
C           Let  V =  ( V1 )
C                     ( V2 )    (last K rows)
C           where  V2  is unit upper triangular.
C
            IF( GLSame( SIDE, 'L' ) ) THEN
C
C              Form  H * C  or  H' * C  where  C = ( C1 )
C                                                  ( C2 )
C
C              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
C
C              W := C2'
C
               DO 70 J = 1, K
                  CALL GCopy( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
   70          CONTINUE
C
C              W := W * V2
C
               CALL GTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
     $                     K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
C
C                 W := W + C1'*V1
C
                  CALL GGEMM( 'Transpose', 'No transpose', N, K, M-K,
     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
C
C              W := W * T'  or  W * T
C
               CALL GTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - V * W'
C
               IF( M.GT.K ) THEN
C
C                 C1 := C1 - V1 * W'
C
                  CALL GGEMM( 'No transpose', 'Transpose', M-K, N, K,
     $                        -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
               END IF
C
C              W := W * V2'
C
               CALL GTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
     $                     ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
C
C              C2 := C2 - W'
C
               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
C
            ELSE IF( GLSame( SIDE, 'R' ) ) THEN
C
C              Form  C * H  or  C * H'  where  C = ( C1  C2 )
C
C              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
C
C              W := C2
C
               DO 100 J = 1, K
                  CALL GCopy( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
  100          CONTINUE
C
C              W := W * V2
C
               CALL GTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
     $                     K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
C
C                 W := W + C1 * V1
C
                  CALL GGEMM( 'No transpose', 'No transpose', M, K, N-K,
     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
C
C              W := W * T  or  W * T'
C
               CALL GTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - W * V'
C
               IF( N.GT.K ) THEN
C
C                 C1 := C1 - W * V1'
C
                  CALL GGEMM( 'No transpose', 'Transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
               END IF
C
C              W := W * V2'
C
               CALL GTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
     $                     ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
C
C              C2 := C2 - W
C
               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
C
      ELSE IF( GLSame( STOREV, 'R' ) ) THEN
C
         IF( GLSame( DIRECT, 'F' ) ) THEN
C
C           Let  V =  ( V1  V2 )    (V1: first K columns)
C           where  V1  is unit upper triangular.
C
            IF( GLSame( SIDE, 'L' ) ) THEN
C
C              Form  H * C  or  H' * C  where  C = ( C1 )
C                                                  ( C2 )
C
C              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
C
C              W := C1'
C
               DO 130 J = 1, K
                  CALL GCopy( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
  130          CONTINUE
C
C              W := W * V1'
C
               CALL GTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
     $                     ONE, V, LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
C
C                 W := W + C2'*V2'
C
                  CALL GGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
     $                        C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
     $                        WORK, LDWORK )
               END IF
C
C              W := W * T'  or  W * T
C
               CALL GTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - V' * W'
C
               IF( M.GT.K ) THEN
C
C                 C2 := C2 - V2' * W'
C
                  CALL GGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
     $                        V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
     $                        C( K+1, 1 ), LDC )
               END IF
C
C              W := W * V1
C
               CALL GTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
     $                     K, ONE, V, LDV, WORK, LDWORK )
C
C              C1 := C1 - W'
C
               DO 150 J = 1, K
                  DO 140 I = 1, N
                     C( J, I ) = C( J, I ) - WORK( I, J )
  140             CONTINUE
  150          CONTINUE
C
            ELSE IF( GLSame( SIDE, 'R' ) ) THEN
C
C              Form  C * H  or  C * H'  where  C = ( C1  C2 )
C
C              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
C
C              W := C1
C
               DO 160 J = 1, K
                  CALL GCopy( M, C( 1, J ), 1, WORK( 1, J ), 1 )
  160          CONTINUE
C
C              W := W * V1'
C
               CALL GTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
     $                     ONE, V, LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
C
C                 W := W + C2 * V2'
C
                  CALL GGEMM( 'No transpose', 'Transpose', M, K, N-K,
     $                        ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
     $                        ONE, WORK, LDWORK )
               END IF
C
C              W := W * T  or  W * T'
C
               CALL GTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - W * V
C
               IF( N.GT.K ) THEN
C
C                 C2 := C2 - W * V2
C
                  CALL GGEMM( 'No transpose', 'No transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
     $                        C( 1, K+1 ), LDC )
               END IF
C
C              W := W * V1
C
               CALL GTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
     $                     K, ONE, V, LDV, WORK, LDWORK )
C
C              C1 := C1 - W
C
               DO 180 J = 1, K
                  DO 170 I = 1, M
                     C( I, J ) = C( I, J ) - WORK( I, J )
  170             CONTINUE
  180          CONTINUE
C
            END IF
C
         ELSE
C
C           Let  V =  ( V1  V2 )    (V2: last K columns)
C           where  V2  is unit lower triangular.
C
            IF( GLSame( SIDE, 'L' ) ) THEN
C
C              Form  H * C  or  H' * C  where  C = ( C1 )
C                                                  ( C2 )
C
C              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
C
C              W := C2'
C
               DO 190 J = 1, K
                  CALL GCopy( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
  190          CONTINUE
C
C              W := W * V2'
C
               CALL GTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
     $                     ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
C
C                 W := W + C1'*V1'
C
                  CALL GGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
     $                        C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
C
C              W := W * T'  or  W * T
C
               CALL GTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - V' * W'
C
               IF( M.GT.K ) THEN
C
C                 C1 := C1 - V1' * W'
C
                  CALL GGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
     $                        V, LDV, WORK, LDWORK, ONE, C, LDC )
               END IF
C
C              W := W * V2
C
               CALL GTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
     $                     K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
C
C              C2 := C2 - W'
C
               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
C
            ELSE IF( GLSame( SIDE, 'R' ) ) THEN
C
C              Form  C * H  or  C * H'  where  C = ( C1  C2 )
C
C              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
C
C              W := C2
C
               DO 220 J = 1, K
                  CALL GCopy( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
  220          CONTINUE
C
C              W := W * V2'
C
               CALL GTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
     $                     ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
C
C                 W := W + C1 * V1'
C
                  CALL GGEMM( 'No transpose', 'Transpose', M, K, N-K,
     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
C
C              W := W * T  or  W * T'
C
               CALL GTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - W * V
C
               IF( N.GT.K ) THEN
C
C                 C1 := C1 - W * V1
C
                  CALL GGEMM( 'No transpose', 'No transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
               END IF
C
C              W := W * V2
C
               CALL GTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
     $                     K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
C
C              C1 := C1 - W
C
               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
C
            END IF
C
         END IF
      END IF
C
      RETURN
      END
*Deck DLARFG
      SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
      INTEGER            INCX, N
      Real*8   ALPHA, TAU
      Real*8   X( * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  DLARFG generates a real elementary reflector H of order n, such
C  that
C
C        H * ( alpha ) = ( beta ),   H' * H = I.
C            (   x   )   (   0  )
C
C  where alpha and beta are scalars, and x is an (n-1)-element real
C  vector. H is represented in the form
C
C        H = I - tau * ( 1 ) * ( 1 v' ) ,
C                      ( v )
C
C  where tau is a real scalar and v is a real (n-1)-element
C  vector.
C
C  If the elements of x are all zero, then tau = 0 and H is taken to be
C  the unit matrix.
C
C  Otherwise  1 <= tau <= 2.
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The order of the elementary reflector.
C
C  ALPHA   (input/output) Real*8
C          On entry, the value alpha.
C          On exit, it is overwritten with the value beta.
C
C  X       (input/output) Real*8 array, dimension
C                         (1+(N-2)*abs(INCX))
C          On entry, the vector x.
C          On exit, it is overwritten with the vector v.
C
C  INCX    (input) INTEGER
C          The increment between elements of X. INCX > 0.
C
C  TAU     (output) Real*8
C          The value tau.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            J, KNT
      Real*8   BETA, RSAFMN, SAFMIN, XNORM
C     ..
C     .. Executable Statements ..
C
      IF( N.LE.1 ) THEN
         TAU = ZERO
         RETURN
      END IF
C
      XNORM = GNrm2( N-1, X, INCX )
C
      IF( XNORM.EQ.ZERO ) THEN
C
C        H  =  I
C
         TAU = ZERO
      ELSE
C
C        general case
C
         BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
         SAFMIN = SFMin / Eps
         IF( ABS( BETA ).LT.SAFMIN ) THEN
C
C           XNORM, BETA may be inaccurate; scale X and recompute them
C
            RSAFMN = ONE / SAFMIN
            KNT = 0
   10       CONTINUE
            KNT = KNT + 1
            CALL GSCAL( N-1, RSAFMN, X, INCX )
            BETA = BETA*RSAFMN
            ALPHA = ALPHA*RSAFMN
            IF( ABS( BETA ).LT.SAFMIN )
     $         GO TO 10
C
C           New BETA is at most 1, at least SAFMIN
C
            XNORM = GNrm2( N-1, X, INCX )
            BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
            TAU = ( BETA-ALPHA ) / BETA
            CALL GScal( N-1, ONE / ( ALPHA-BETA ), X, INCX )
C
C           If ALPHA is subnormal, it may lose relative accuracy
C
            ALPHA = BETA
            DO 20 J = 1, KNT
               ALPHA = ALPHA*SAFMIN
   20       CONTINUE
         ELSE
            TAU = ( BETA-ALPHA ) / BETA
            CALL GScal( N-1, ONE / ( ALPHA-BETA ), X, INCX )
            ALPHA = BETA
         END IF
      END IF
C
      RETURN
      END
*Deck DLARFT
      SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER*(*)      DIRECT, STOREV
      INTEGER            K, LDT, LDV, N
C     ..
C     .. Array Arguments ..
      Real*8   T( LDT, * ), TAU( * ), V( LDV, * )
C     ..
C
C  Purpose
C  =======
C
C  DLARFT forms the triangular factor T of a real block reflector H
C  of order n, which is defined as a product of k elementary reflectors.
C
C  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
C
C  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
C
C  If STOREV = 'C', the vector which defines the elementary reflector
C  H(i) is stored in the i-th column of the array V, and
C
C     H  =  I - V * T * V'
C
C  If STOREV = 'R', the vector which defines the elementary reflector
C  H(i) is stored in the i-th row of the array V, and
C
C     H  =  I - V' * T * V
C
C  Arguments
C  =========
C
C  DIRECT  (input) CHARACTER*1
C          Specifies the order in which the elementary reflectors are
C          multiplied to form the block reflector:
C          = 'F': H = H(1) H(2) . . . H(k) (Forward)
C          = 'B': H = H(k) . . . H(2) H(1) (Backward)
C
C  STOREV  (input) CHARACTER*1
C          Specifies how the vectors which define the elementary
C          reflectors are stored (see also Further Details):
C          = 'C': columnwise
C          = 'R': rowwise
C
C  N       (input) INTEGER
C          The order of the block reflector H. N >= 0.
C
C  K       (input) INTEGER
C          The order of the triangular factor T (= the number of
C          elementary reflectors). K >= 1.
C
C  V       (input/output) Real*8 array, dimension
C                               (LDV,K) if STOREV = 'C'
C                               (LDV,N) if STOREV = 'R'
C          The matrix V. See further details.
C
C  LDV     (input) INTEGER
C          The leading dimension of the array V.
C          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
C
C  TAU     (input) Real*8 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i).
C
C  T       (output) Real*8 array, dimension (LDT,K)
C          The k by k triangular factor T of the block reflector.
C          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
C          lower triangular. The rest of the array is not used.
C
C  LDT     (input) INTEGER
C          The leading dimension of the array T. LDT >= K.
C
C  Further Details
C  ===============
C
C  The shape of the matrix V and the storage of the vectors which define
C  the H(i) is best illustrated by the following example with n = 5 and
C  k = 3. The elements equal to 1 are not stored; the corresponding
C  array elements are modified but restored on exit. The rest of the
C  array is not used.
C
C  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
C
C               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
C                   ( v1  1    )                     (     1 v2 v2 v2 )
C                   ( v1 v2  1 )                     (        1 v3 v3 )
C                   ( v1 v2 v3 )
C                   ( v1 v2 v3 )
C
C  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
C
C               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
C                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
C                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
C                   (     1 v3 )
C                   (        1 )
C
C  =====================================================================
C
C     .. Parameters ..
      Logical GLSame
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, J
      Real*8   VII
C     ..
C     .. Executable Statements ..
C
C     Quick return if possible
C
      IF( N.EQ.0 )
     $   RETURN
C
      IF( GLSame( DIRECT, 'F' ) ) THEN
         DO 20 I = 1, K
            IF( TAU( I ).EQ.ZERO ) THEN
C
C              H(i)  =  I
C
               DO 10 J = 1, I
                  T( J, I ) = ZERO
   10          CONTINUE
            ELSE
C
C              general case
C
               VII = V( I, I )
               V( I, I ) = ONE
               IF( GLSame( STOREV, 'C' ) ) THEN
C
C                 T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
C
                  CALL GGEMV( 'Transpose', N-I+1, I-1, -TAU( I ),
     $                        V( I, 1 ), LDV, V( I, I ), 1, ZERO,
     $                        T( 1, I ), 1 )
               ELSE
C
C                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
C
                  CALL GGEMV( '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
C
C              T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
C
               CALL GTRMV( '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
C
C              H(i)  =  I
C
               DO 30 J = I, K
                  T( J, I ) = ZERO
   30          CONTINUE
            ELSE
C
C              general case
C
               IF( I.LT.K ) THEN
                  IF( GLSame( STOREV, 'C' ) ) THEN
                     VII = V( N-K+I, I )
                     V( N-K+I, I ) = ONE
C
C                    T(i+1:k,i) :=
C                            - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
C
                     CALL GGEMV( '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
C
C                    T(i+1:k,i) :=
C                            - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
C
                     CALL GGEMV( '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
C
C                 T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
C
                  CALL GTRMV( '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
*Deck DLARTG
      Subroutine DLARTG( F, G, CS, SN, R )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      Real*8   CS, F, G, R, SN
C     ..
C
C  Purpose
C  =======
C
C  DLARTG generate a plane rotation so that
C
C     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
C     [ -SN  CS  ]     [ G ]     [ 0 ]
C
C  This is a slower, more accurate version of the BLAS1 routine DROTG,
C  with the following other differences:
C     F and G are unchanged on return.
C     If G=0, then CS=1 and SN=0.
C     If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
C        floating point operations (saves work in DBDSQR when
C        there are zeros on the diagonal).
C
C  If F exceeds G in magnitude, CS will be positive.
C
C  Arguments
C  =========
C
C  F       (input) Real*8
C          The first component of vector to be rotated.
C
C  G       (input) Real*8
C          The second component of vector to be rotated.
C
C  CS      (output) Real*8
C          The cosine of the rotation.
C
C  SN      (output) Real*8
C          The sine of the rotation.
C
C  R       (output) Real*8
C          The nonzero component of the rotated vector.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D0 )
      Real*8   TWO
      PARAMETER          ( TWO = 2.0D0 )
      INTEGER            COUNT, I
      Real*8   EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
      SAFMIN = SFMin
      SAFMN2 = Base**INT( LOG( SAFMIN / EPS ) / LOG(Base) / TWO )
      SAFMX2 = ONE / SAFMN2
      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
*Deck DLAS2
      SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      Real*8   F, G, H, SSMAX, SSMIN
C     ..
C
C  Purpose
C  =======
C
C  DLAS2  computes the singular values of the 2-by-2 matrix
C     [  F   G  ]
C     [  0   H  ].
C  On return, SSMIN is the smaller singular value and SSMAX is the
C  larger singular value.
C
C  Arguments
C  =========
C
C  F       (input) Real*8
C          The (1,1) element of the 2-by-2 matrix.
C
C  G       (input) Real*8
C          The (1,2) element of the 2-by-2 matrix.
C
C  H       (input) Real*8
C          The (2,2) element of the 2-by-2 matrix.
C
C  SSMIN   (output) Real*8
C          The smaller singular value.
C
C  SSMAX   (output) Real*8
C          The larger singular value.
C
C  Further Details
C  ===============
C
C  Barring over/underflow, all output quantities are correct to within
C  a few units in the last place (ulps), even in the absence of a guard
C  digit in addition/subtraction.
C
C  In IEEE arithmetic, the code works correctly if one matrix element is
C  infinite.
C
C  Overflow will not occur unless the largest singular value itself
C  overflows, or is within a few ulps of overflow. (On machines with
C  partial overflow, like the Cray, overflow may occur if the largest
C  singular value is within a factor of 2 of overflow.)
C
C  Underflow is harmless if underflow is gradual. Otherwise, results
C  may correspond to a matrix modified by perturbations of size near
C  the underflow threshold.
C
C  ====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D0 )
      Real*8   TWO
      PARAMETER          ( TWO = 2.0D0 )
C     ..
C     .. Local Scalars ..
      Real*8   AS, AT, AU, C, FA, FHMN, FHMX, GA, HA
C     ..
C     .. Executable Statements ..
C
      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
C
C              Avoid possible harmful underflow if exponent range
C              asymmetric (true SSMIN may not underflow even if
C              AU underflows)
C
               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
*Deck DLASCL
      SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
      CHARACTER          TYPE
      INTEGER            INFO, KL, KU, LDA, M, N
      Real*8   CFROM, CTO
      Real*8   A( LDA, * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  DLASCL multiplies the M by N real matrix A by the real scalar
C  CTO/CFROM.  This is done without over/underflow as long as the final
C  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
C  A may be full, upper triangular, lower triangular, upper Hessenberg,
C  or banded.
C
C  Arguments
C  =========
C
C  TYPE    (input) CHARACTER*1
C          TYPE indices the storage type of the input matrix.
C          = 'G':  A is a full matrix.
C          = 'L':  A is a lower triangular matrix.
C          = 'U':  A is an upper triangular matrix.
C          = 'H':  A is an upper Hessenberg matrix.
C          = 'B':  A is a symmetric band matrix with lower bandwidth KL
C                  and upper bandwidth KU and with the only the lower
C                  half stored.
C          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
C                  and upper bandwidth KU and with the only the upper
C                  half stored.
C          = 'Z':  A is a band matrix with lower bandwidth KL and upper
C                  bandwidth KU.
C
C  KL      (input) INTEGER
C          The lower bandwidth of A.  Referenced only if TYPE = 'B',
C          'Q' or 'Z'.
C
C  KU      (input) INTEGER
C          The upper bandwidth of A.  Referenced only if TYPE = 'B',
C          'Q' or 'Z'.
C
C  CFROM   (input) Real*8
C  CTO     (input) Real*8
C          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
C          without over/underflow if the final result CTO*A(I,J)/CFROM
C          can be represented without over/underflow.  CFROM must be
C          nonzero.
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,M)
C          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
C          storage type.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  INFO    (output) INTEGER
C          0  - successful exit
C          <0 - if INFO = -i, the i-th argument had an illegal value.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            DONE
      INTEGER            I, ITYPE, J, K1, K2, K3, K4
      Real*8   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
C
      IF( GLSame( TYPE, 'G' ) ) THEN
         ITYPE = 0
      ELSE IF( GLSame( TYPE, 'L' ) ) THEN
         ITYPE = 1
      ELSE IF( GLSame( TYPE, 'U' ) ) THEN
         ITYPE = 2
      ELSE IF( GLSame( TYPE, 'H' ) ) THEN
         ITYPE = 3
      ELSE IF( GLSame( TYPE, 'B' ) ) THEN
         ITYPE = 4
      ELSE IF( GLSame( TYPE, 'Q' ) ) THEN
         ITYPE = 5
      ELSE IF( GLSame( TYPE, 'Z' ) ) THEN
         ITYPE = 6
      ELSE
         ITYPE = -1
      END IF
C
      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) Call GLBErr('DLASCL',Info)
      If(N.eq.0.or.M.eq.0) RETURN
C
C     Get machine parameters
C
      SMLNUM = SFMin
      BIGNUM = ONE / SMLNUM
C
      CFROMC = CFROM
      CTOC = CTO
C
   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
C
      IF( ITYPE.EQ.0 ) THEN
C
C        Full matrix
C
         DO 30 J = 1, N
            DO 20 I = 1, M
               A( I, J ) = A( I, J )*MUL
   20       CONTINUE
   30    CONTINUE
C
      ELSE IF( ITYPE.EQ.1 ) THEN
C
C        Lower triangular matrix
C
         DO 50 J = 1, N
            DO 40 I = J, M
               A( I, J ) = A( I, J )*MUL
   40       CONTINUE
   50    CONTINUE
C
      ELSE IF( ITYPE.EQ.2 ) THEN
C
C        Upper triangular matrix
C
         DO 70 J = 1, N
            DO 60 I = 1, MIN( J, M )
               A( I, J ) = A( I, J )*MUL
   60       CONTINUE
   70    CONTINUE
C
      ELSE IF( ITYPE.EQ.3 ) THEN
C
C        Upper Hessenberg matrix
C
         DO 90 J = 1, N
            DO 80 I = 1, MIN( J+1, M )
               A( I, J ) = A( I, J )*MUL
   80       CONTINUE
   90    CONTINUE
C
      ELSE IF( ITYPE.EQ.4 ) THEN
C
C        Lower half of a symmetric band matrix
C
         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
C
      ELSE IF( ITYPE.EQ.5 ) THEN
C
C        Upper half of a symmetric band matrix
C
         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
C
      ELSE IF( ITYPE.EQ.6 ) THEN
C
C        Band matrix
C
         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
C
      END IF
C
      IF( .NOT.DONE )
     $   GO TO 10
C
      RETURN
      END
*Deck DLASET
      SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      CHARACTER*(*)      UPLO
      INTEGER            LDA, M, N
      Real*8   ALPHA, BETA
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  DLASET initializes an m-by-n matrix A to BETA on the diagonal and
C  ALPHA on the offdiagonals.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies the part of the matrix A to be set.
C          = 'U':      Upper triangular part is set; the strictly lower
C                      triangular part of A is not changed.
C          = 'L':      Lower triangular part is set; the strictly upper
C                      triangular part of A is not changed.
C          Otherwise:  All of the matrix A is set.
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  ALPHA   (input) Real*8
C          The constant to which the offdiagonal elements are to be set.
C
C  BETA    (input) Real*8
C          The constant to which the diagonal elements are to be set.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On exit, the leading m-by-n submatrix of A is set as follows:
C
C          if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,
C          if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,
C          otherwise,     A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,
C
C          and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C =====================================================================
C
C     .. Local Scalars ..
      INTEGER            I, J
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
      IF( GLSame( UPLO, 'U' ) ) THEN
C
C        Set the strictly upper triangular or trapezoidal part of the
C        array to ALPHA.
C
         DO 20 J = 2, N
            DO 10 I = 1, MIN( J-1, M )
               A( I, J ) = ALPHA
   10       CONTINUE
   20    CONTINUE
C
      ELSE IF( GLSame( UPLO, 'L' ) ) THEN
C
C        Set the strictly lower triangular or trapezoidal part of the
C        array to ALPHA.
C
         DO 40 J = 1, MIN( M, N )
            DO 30 I = J + 1, M
               A( I, J ) = ALPHA
   30       CONTINUE
   40    CONTINUE
C
      ELSE
C
C        Set the leading m-by-n submatrix to ALPHA.
C
         DO 60 J = 1, N
            DO 50 I = 1, M
               A( I, J ) = ALPHA
   50       CONTINUE
   60    CONTINUE
      END IF
C
C     Set the first min(M,N) diagonal elements to BETA.
C
      DO 70 I = 1, MIN( M, N )
         A( I, I ) = BETA
   70 CONTINUE
C
      RETURN
      END
*Deck DLASQ1
      SUBROUTINE DLASQ1( N, D, E, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
      INTEGER            INFO, N
      Real*8   D( * ), E( * ), WORK( * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C     Purpose
C     =======
C
C     DLASQ1 computes the singular values of a real N-by-N bidiagonal
C     matrix with diagonal D and off-diagonal E. The singular values are
C     computed to high relative accuracy, barring over/underflow or
C     denormalization. The algorithm is described in
C
C     "Accurate singular values and differential qd algorithms," by
C     K. V. Fernando and B. N. Parlett,
C     Numer. Math., Vol-67, No. 2, pp. 191-230,1994.
C
C     See also
C     "Implementation of differential qd algorithms," by
C     K. V. Fernando and B. N. Parlett, Technical Report,
C     Department of Mathematics, University of California at Berkeley,
C     1994 (Under preparation).
C
C     Arguments
C     =========
C
C  N       (input) INTEGER
C          The number of rows and columns in the matrix. N >= 0.
C
C  D       (input/output) Real*8 array, dimension (N)
C          On entry, D contains the diagonal elements of the
C          bidiagonal matrix whose SVD is desired. On normal exit,
C          D contains the singular values in decreasing order.
C
C  E       (input/output) Real*8 array, dimension (N)
C          On entry, elements E(1:N-1) contain the off-diagonal elements
C          of the bidiagonal matrix whose SVD is desired.
C          On exit, E is overwritten.
C
C  WORK    (workspace) Real*8 array, dimension (2*N)
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C          > 0:  if INFO = i, the algorithm did not converge;  i
C                specifies how many superdiagonals did not converge.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   MEIGTH
      PARAMETER          ( MEIGTH = -0.125D0 )
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D0 )
      Real*8   TEN
      PARAMETER          ( TEN = 10.0D0 )
      Real*8   HUNDRD
      PARAMETER          ( HUNDRD = 100.0D0 )
      Real*8   TWO56
      PARAMETER          ( TWO56 = 256.0D0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            RESTRT
      INTEGER            I, IERR, J, KE, KEND, M, NY
      Real*8   DM, DX, EPS, SCL, SFMIN, SIG1, SIG2, SIGMN,
     $                   SIGMX, SMALL2, THRESH, TOL, TOL2, TOLMUL
C     ..
C     .. Executable Statements ..
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -2
         Call GauErr('Illegal argument to DLASq1.')
         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
C
C     Estimate the largest singular value
C
      SIGMX = ZERO
      DO 10 I = 1, N - 1
         SIGMX = MAX( SIGMX, ABS( E( I ) ) )
   10 CONTINUE
C
C     Early return if sigmx is zero (matrix is already diagonal)
C
      IF( SIGMX.EQ.ZERO )
     $   GO TO 70
C
      DO 20 I = 1, N
         D( I ) = ABS( D( I ) )
         SIGMX = MAX( SIGMX, D( I ) )
   20 CONTINUE
C
C     Compute singular values to relative accuracy TOL
C     It is assumed that tol**2 does not underflow.
C
      TOLMUL = MAX( TEN, MIN( HUNDRD, EPS**( -MEIGTH ) ) )
      TOL = TOLMUL*EPS
      TOL2 = TOL**2
C
      THRESH = SIGMX*SQRT( SFMIN )*TOL
C
C     Scale matrix so the square of the largest element is
C     1 / ( 256 * SFMIN )
C
      SCL = SQRT( ONE / ( TWO56*SFMIN ) )
      SMALL2 = ONE / ( TWO56*TOLMUL**2 )
      CALL GCopy( N, D, 1, WORK( 1 ), 1 )
      CALL GCopy( N-1, E, 1, WORK( N+1 ), 1 )
      CALL DLASCL( 'G', 0, 0, SIGMX, SCL, N, 1, WORK( 1 ), N, IERR )
      CALL DLASCL( 'G', 0, 0, SIGMX, SCL, N-1, 1, WORK( N+1 ), N-1,
     $             IERR )
C
C     Square D and E (the input for the qd algorithm)
C
      DO 30 J = 1, 2*N - 1
         WORK( J ) = WORK( J )**2
   30 CONTINUE
C
C     Apply qd algorithm
C
      M = 0
      E( N ) = ZERO
      DX = WORK( 1 )
      DM = DX
      KE = 0
      RESTRT = .FALSE.
      DO 60 I = 1, N
         IF( ABS( E( I ) ).LE.THRESH .OR. WORK( N+I ).LE.TOL2*
     $       ( DM / GFloat( I-M ) ) ) THEN
            NY = I - M
            IF( NY.EQ.1 ) THEN
               GO TO 50
            ELSE IF( NY.EQ.2 ) THEN
               CALL DLAS2( D( M+1 ), E( M+1 ), D( M+2 ), SIG1, SIG2 )
               D( M+1 ) = SIG1
               D( M+2 ) = SIG2
            ELSE
               KEND = KE + 1 - M
               CALL DLASQ2( NY, D( M+1 ), E( M+1 ), WORK( M+1 ),
     $                      WORK( M+N+1 ), EPS, TOL2, SMALL2, DM, KEND,
     $                      INFO )
C
C                 Return, INFO = number of unconverged superdiagonals
C
               IF( INFO.NE.0 ) THEN
                  INFO = INFO + I
                  RETURN
               END IF
C
C                 Undo scaling
C
               DO 40 J = M + 1, M + NY
                  D( J ) = SQRT( D( J ) )
   40          CONTINUE
               CALL DLASCL( 'G', 0, 0, SCL, SIGMX, NY, 1, D( M+1 ), NY,
     $                      IERR )
            END IF
   50       CONTINUE
            M = I
            IF( I.NE.N ) THEN
               DX = WORK( I+1 )
               DM = DX
               KE = I
               RESTRT = .TRUE.
            END IF
         END IF
         IF( I.NE.N .AND. .NOT.RESTRT ) THEN
            DX = WORK( I+1 )*( DX / ( DX+WORK( N+I ) ) )
            IF( DM.GT.DX ) THEN
               DM = DX
               KE = I
            END IF
         END IF
         RESTRT = .FALSE.
   60 CONTINUE
      KEND = KE + 1
C
C     Sort the singular values into decreasing order
C
   70 CONTINUE
      CALL DLASRT( 'D', N, D, INFO )
      RETURN
      END
*Deck DLASQ2
      SUBROUTINE DLASQ2( M, Q, E, QQ, EE, EPS, TOL2, SMALL2, SUP, KEND,
     $                   INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, KEND, M
      Real*8   EPS, SMALL2, SUP, TOL2
C     ..
C     .. Array Arguments ..
      Real*8   E( * ), EE( * ), Q( * ), QQ( * )
C     ..
C
C     Purpose
C     =======
C
C     DLASQ2 computes the singular values of a real N-by-N unreduced
C     bidiagonal matrix with squared diagonal elements in Q and
C     squared off-diagonal elements in E. The singular values are
C     computed to relative accuracy TOL, barring over/underflow or
C     denormalization.
C
C     Arguments
C     =========
C
C  M       (input) INTEGER
C          The number of rows and columns in the matrix. M >= 0.
C
C  Q       (output) Real*8 array, dimension (M)
C          On normal exit, contains the squared singular values.
C
C  E       (workspace) Real*8 array, dimension (M)
C
C  QQ      (input/output) Real*8 array, dimension (M)
C          On entry, QQ contains the squared diagonal elements of the
C          bidiagonal matrix whose SVD is desired.
C          On exit, QQ is overwritten.
C
C  EE      (input/output) Real*8 array, dimension (M)
C          On entry, EE(1:N-1) contains the squared off-diagonal
C          elements of the bidiagonal matrix whose SVD is desired.
C          On exit, EE is overwritten.
C
C  EPS     (input) Real*8
C          Machine epsilon.
C
C  TOL2    (input) Real*8
C          Desired relative accuracy of computed eigenvalues
C          as defined in DLASQ1.
C
C  SMALL2  (input) Real*8
C          A threshold value as defined in DLASQ1.
C
C  SUP     (input/output) Real*8
C          Upper bound for the smallest eigenvalue.
C
C  KEND    (input/output) INTEGER
C          Index where minimum d occurs.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C          > 0:  if INFO = i, the algorithm did not converge;  i
C                specifies how many superdiagonals did not converge.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      Real*8   FOUR, HALF
      PARAMETER          ( FOUR = 4.0D+0, HALF = 0.5D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            ICONV, IPHASE, ISP, N, OFF, OFF1
      Real*8   QEMAX, SIGMA, XINF, XX, YY
C     ..
C     .. Executable Statements ..
      N = M
C
C     Set the default maximum number of iterations
C
      OFF = 0
      OFF1 = OFF + 1
      SIGMA = ZERO
      XINF = ZERO
      ICONV = 0
      IPHASE = 2
C
C     Try deflation at the bottom
C
C     1x1 deflation
C
   10 CONTINUE
      IF( N.LE.2 )
     $   GO TO 20
      IF( EE( N-1 ).LE.MAX( QQ( N ), XINF, SMALL2 )*TOL2 ) THEN
         Q( N ) = QQ( N )
         N = N - 1
         IF( KEND.GT.N )
     $      KEND = N
         SUP = MIN( QQ( N ), QQ( N-1 ) )
         GO TO 10
      END IF
C
C     2x2 deflation
C
      IF( EE( N-2 ).LE.MAX( XINF, SMALL2,
     $    ( QQ( N ) / ( QQ( N )+EE( N-1 )+QQ( N-1 ) ) )*QQ( N-1 ) )*
     $    TOL2 ) THEN
         QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) )
         IF( QEMAX.NE.ZERO ) THEN
            IF( QEMAX.EQ.QQ( N-1 ) ) THEN
               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
     $              SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) /
     $              QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) )
            ELSE IF( QEMAX.EQ.QQ( N ) ) THEN
               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
     $              SQRT( ( ( QQ( N-1 )-QQ( N )+EE( N-1 ) ) /
     $              QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) )
            ELSE
               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
     $              SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) /
     $              QEMAX )**2+FOUR*QQ( N-1 ) / QEMAX ) )
            END IF
            YY = ( MAX( QQ( N ), QQ( N-1 ) ) / XX )*
     $           MIN( QQ( N ), QQ( N-1 ) )
         ELSE
            XX = ZERO
            YY = ZERO
         END IF
         Q( N-1 ) = XX
         Q( N ) = YY
         N = N - 2
         IF( KEND.GT.N )
     $      KEND = N
         SUP = QQ( N )
         GO TO 10
      END IF
C
   20 CONTINUE
      IF( N.EQ.0 ) THEN
C
C         The lower branch is finished
C
         IF( OFF.EQ.0 ) THEN
C
C         No upper branch; return to DLASQ1
C
            RETURN
         ELSE
C
C         Going back to upper branch
C
            XINF = ZERO
            IF( EE( OFF ).GT.ZERO ) THEN
               ISP = NINT( EE( OFF ) )
               IPHASE = 1
            ELSE
               ISP = -NINT( EE( OFF ) )
               IPHASE = 2
            END IF
            SIGMA = E( OFF )
            N = OFF - ISP + 1
            OFF1 = ISP
            OFF = OFF1 - 1
            IF( N.LE.2 )
     $         GO TO 20
            IF( IPHASE.EQ.1 ) THEN
               SUP = MIN( Q( N+OFF ), Q( N-1+OFF ), Q( N-2+OFF ) )
            ELSE
               SUP = MIN( QQ( N+OFF ), QQ( N-1+OFF ), QQ( N-2+OFF ) )
            END IF
            KEND = 0
            ICONV = -3
         END IF
      ELSE IF( N.EQ.1 ) THEN
C
C     1x1 Solver
C
         IF( IPHASE.EQ.1 ) THEN
            Q( OFF1 ) = Q( OFF1 ) + SIGMA
         ELSE
            Q( OFF1 ) = QQ( OFF1 ) + SIGMA
         END IF
         N = 0
         GO TO 20
C
C     2x2 Solver
C
      ELSE IF( N.EQ.2 ) THEN
         IF( IPHASE.EQ.2 ) THEN
            QEMAX = MAX( QQ( N+OFF ), QQ( N-1+OFF ), EE( N-1+OFF ) )
            IF( QEMAX.NE.ZERO ) THEN
               IF( QEMAX.EQ.QQ( N-1+OFF ) ) THEN
                  XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+
     $                 QEMAX*SQRT( ( ( QQ( N+OFF )-QQ( N-1+OFF )+EE( N-
     $                 1+OFF ) ) / QEMAX )**2+FOUR*EE( OFF+N-1 ) /
     $                 QEMAX ) )
               ELSE IF( QEMAX.EQ.QQ( N+OFF ) ) THEN
                  XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+
     $                 QEMAX*SQRT( ( ( QQ( N-1+OFF )-QQ( N+OFF )+EE( N-
     $                 1+OFF ) ) / QEMAX )**2+FOUR*EE( N-1+OFF ) /
     $                 QEMAX ) )
               ELSE
                  XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+
     $                 QEMAX*SQRT( ( ( QQ( N+OFF )-QQ( N-1+OFF )+EE( N-
     $                 1+OFF ) ) / QEMAX )**2+FOUR*QQ( N-1+OFF ) /
     $                 QEMAX ) )
               END IF
               YY = ( MAX( QQ( N+OFF ), QQ( N-1+OFF ) ) / XX )*
     $              MIN( QQ( N+OFF ), QQ( N-1+OFF ) )
            ELSE
               XX = ZERO
               YY = ZERO
            END IF
         ELSE
            QEMAX = MAX( Q( N+OFF ), Q( N-1+OFF ), E( N-1+OFF ) )
            IF( QEMAX.NE.ZERO ) THEN
               IF( QEMAX.EQ.Q( N-1+OFF ) ) THEN
                  XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+
     $                 QEMAX*SQRT( ( ( Q( N+OFF )-Q( N-1+OFF )+E( N-1+
     $                 OFF ) ) / QEMAX )**2+FOUR*E( N-1+OFF ) /
     $                 QEMAX ) )
               ELSE IF( QEMAX.EQ.Q( N+OFF ) ) THEN
                  XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+
     $                 QEMAX*SQRT( ( ( Q( N-1+OFF )-Q( N+OFF )+E( N-1+
     $                 OFF ) ) / QEMAX )**2+FOUR*E( N-1+OFF ) /
     $                 QEMAX ) )
               ELSE
                  XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+
     $                 QEMAX*SQRT( ( ( Q( N+OFF )-Q( N-1+OFF )+E( N-1+
     $                 OFF ) ) / QEMAX )**2+FOUR*Q( N-1+OFF ) /
     $                 QEMAX ) )
               END IF
               YY = ( MAX( Q( N+OFF ), Q( N-1+OFF ) ) / XX )*
     $              MIN( Q( N+OFF ), Q( N-1+OFF ) )
            ELSE
               XX = ZERO
               YY = ZERO
            END IF
         END IF
         Q( N-1+OFF ) = SIGMA + XX
         Q( N+OFF ) = YY + SIGMA
         N = 0
         GO TO 20
      END IF
      CALL DLASQ3( N, Q( OFF1 ), E( OFF1 ), QQ( OFF1 ), EE( OFF1 ), SUP,
     $             SIGMA, KEND, OFF, IPHASE, ICONV, EPS, TOL2, SMALL2 )
      IF( SUP.LT.ZERO ) THEN
         INFO = N + OFF
         RETURN
      END IF
      OFF1 = OFF + 1
      GO TO 20
      END
*Deck DLASQ3
      SUBROUTINE DLASQ3( N, Q, E, QQ, EE, SUP, SIGMA, KEND, OFF, IPHASE,
     $                   ICONV, EPS, TOL2, SMALL2 )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            ICONV, IPHASE, KEND, N, OFF
      Real*8   EPS, SIGMA, SMALL2, SUP, TOL2
C     ..
C     .. Array Arguments ..
      Real*8   E( * ), EE( * ), Q( * ), QQ( * )
C     ..
C
C     Purpose
C     =======
C
C     DLASQ3 is the workhorse of the whole bidiagonal SVD algorithm.
C     This can be described as the differential qd with shifts.
C
C     Arguments
C     =========
C
C  N       (input/output) INTEGER
C          On entry, N specifies the number of rows and columns
C          in the matrix. N must be at least 3.
C          On exit N is non-negative and less than the input value.
C
C  Q       (input/output) Real*8 array, dimension (N)
C          Q array in ping (see IPHASE below)
C
C  E       (input/output) Real*8 array, dimension (N)
C          E array in ping (see IPHASE below)
C
C  QQ      (input/output) Real*8 array, dimension (N)
C          Q array in pong (see IPHASE below)
C
C  EE      (input/output) Real*8 array, dimension (N)
C          E array in pong (see IPHASE below)
C
C  SUP     (input/output) Real*8
C          Upper bound for the smallest eigenvalue
C
C  SIGMA   (input/output) Real*8
C          Accumulated shift for the present submatrix
C
C  KEND    (input/output) INTEGER
C          Index where minimum D(i) occurs in recurrence for
C          splitting criterion
C
C  OFF     (input/output) INTEGER
C          Offset for arrays
C
C  IPHASE  (input/output) INTEGER
C          If IPHASE = 1 (ping) then data is in Q and E arrays
C          If IPHASE = 2 (pong) then data is in QQ and EE arrays
C
C  ICONV   (input) INTEGER
C          If ICONV = 0 a bottom part of a matrix (with a split)
C          If ICONV =-3 a top part of a matrix (with a split)
C
C  EPS     (input) Real*8
C          Machine epsilon
C
C  TOL2    (input) Real*8
C          Square of the relative tolerance TOL as defined in DLASQ1
C
C  SMALL2  (input) Real*8
C          A threshold value as defined in DLASQ1
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      INTEGER            NPP
      PARAMETER          ( NPP = 32 )
      INTEGER            IPP
      PARAMETER          ( IPP = 5 )
      Real*8   HALF, FOUR
      PARAMETER          ( HALF = 0.5D+0, FOUR = 4.0D+0 )
      INTEGER            IFLMAX
      PARAMETER          ( IFLMAX = 2 )
C     ..
C     .. Local Scalars ..
      LOGICAL            LDEF, LSPLIT
      INTEGER            I, IC, ICNT, IFL, IP, ISP, K1END, K2END, KE,
     $                   KS, MAXIT, N1, N2
      Real*8   D, DM, QEMAX, T1, TAU, TOLX, TOLY, TOLZ, XX, YY
C     ..
C     .. Executable Statements ..
      ICNT = 0
      TAU = ZERO
      DM = SUP
      TOLX = SIGMA*TOL2
      TOLZ = MAX( SMALL2, SIGMA )*TOL2
C
C     Set maximum number of iterations
C
      MAXIT = 100*N
C
C     Flipping
C
      IC = 2
      IF( N.GT.3 ) THEN
         IF( IPHASE.EQ.1 ) THEN
            DO 10 I = 1, N - 2
               IF( Q( I ).GT.Q( I+1 ) )
     $            IC = IC + 1
               IF( E( I ).GT.E( I+1 ) )
     $            IC = IC + 1
   10       CONTINUE
            IF( Q( N-1 ).GT.Q( N ) )
     $         IC = IC + 1
            IF( IC.LT.N ) THEN
               CALL GCopy( N, Q, 1, QQ, -1 )
               CALL GCopy( N-1, E, 1, EE, -1 )
               IF( KEND.NE.0 )
     $            KEND = N - KEND + 1
               IPHASE = 2
            END IF
         ELSE
            DO 20 I = 1, N - 2
               IF( QQ( I ).GT.QQ( I+1 ) )
     $            IC = IC + 1
               IF( EE( I ).GT.EE( I+1 ) )
     $            IC = IC + 1
   20       CONTINUE
            IF( QQ( N-1 ).GT.QQ( N ) )
     $         IC = IC + 1
            IF( IC.LT.N ) THEN
               CALL GCopy( N, QQ, 1, Q, -1 )
               CALL GCopy( N-1, EE, 1, E, -1 )
               IF( KEND.NE.0 )
     $            KEND = N - KEND + 1
               IPHASE = 1
            END IF
         END IF
      END IF
      IF( ICONV.EQ.-3 ) THEN
         IF( IPHASE.EQ.1 ) THEN
            GO TO 180
         ELSE
            GO TO 80
         END IF
      END IF
      IF( IPHASE.EQ.2 )
     $   GO TO 130
C
C     The ping section of the code
C
   30 CONTINUE
      IFL = 0
C
C     Compute the shift
C
      IF( KEND.EQ.0 .OR. SUP.EQ.ZERO ) THEN
         TAU = ZERO
      ELSE IF( ICNT.GT.0 .AND. DM.LE.TOLZ ) THEN
         TAU = ZERO
      ELSE
         IP = MAX( IPP, N / NPP )
         N2 = 2*IP + 1
         IF( N2.GE.N ) THEN
            N1 = 1
            N2 = N
         ELSE IF( KEND+IP.GT.N ) THEN
            N1 = N - 2*IP
         ELSE IF( KEND-IP.LT.1 ) THEN
            N1 = 1
         ELSE
            N1 = KEND - IP
         END IF
         CALL DLASQ4( N2, Q( N1 ), E( N1 ), TAU, SUP )
      END IF
   40 CONTINUE
      ICNT = ICNT + 1
      IF( ICNT.GT.MAXIT ) THEN
         SUP = -ONE
         RETURN
      END IF
      IF( TAU.EQ.ZERO ) THEN
C
C     dqd algorithm
C
         D = Q( 1 )
         DM = D
         KE = 0
         DO 50 I = 1, N - 3
            QQ( I ) = D + E( I )
            D = ( D / QQ( I ) )*Q( I+1 )
            IF( DM.GT.D ) THEN
               DM = D
               KE = I
            END IF
   50    CONTINUE
         KE = KE + 1
C
C     Penultimate dqd step (in ping)
C
         K2END = KE
         QQ( N-2 ) = D + E( N-2 )
         D = ( D / QQ( N-2 ) )*Q( N-1 )
         IF( DM.GT.D ) THEN
            DM = D
            KE = N - 1
         END IF
C
C     Final dqd step (in ping)
C
         K1END = KE
         QQ( N-1 ) = D + E( N-1 )
         D = ( D / QQ( N-1 ) )*Q( N )
         IF( DM.GT.D ) THEN
            DM = D
            KE = N
         END IF
         QQ( N ) = D
      ELSE
C
C     The dqds algorithm (in ping)
C
         D = Q( 1 ) - TAU
         DM = D
         KE = 0
         IF( D.LT.ZERO )
     $      GO TO 120
         DO 60 I = 1, N - 3
            QQ( I ) = D + E( I )
            D = ( D / QQ( I ) )*Q( I+1 ) - TAU
            IF( DM.GT.D ) THEN
               DM = D
               KE = I
               IF( D.LT.ZERO )
     $            GO TO 120
            END IF
   60    CONTINUE
         KE = KE + 1
C
C     Penultimate dqds step (in ping)
C
         K2END = KE
         QQ( N-2 ) = D + E( N-2 )
         D = ( D / QQ( N-2 ) )*Q( N-1 ) - TAU
         IF( DM.GT.D ) THEN
            DM = D
            KE = N - 1
            IF( D.LT.ZERO )
     $         GO TO 120
         END IF
C
C     Final dqds step (in ping)
C
         K1END = KE
         QQ( N-1 ) = D + E( N-1 )
         D = ( D / QQ( N-1 ) )*Q( N ) - TAU
         IF( DM.GT.D ) THEN
            DM = D
            KE = N
         END IF
         QQ( N ) = D
      END IF
C
C        Convergence when QQ(N) is small (in ping)
C
      IF( ABS( QQ( N ) ).LE.SIGMA*TOL2 ) THEN
         QQ( N ) = ZERO
         DM = ZERO
         KE = N
      END IF
      IF( QQ( N ).LT.ZERO )
     $   GO TO 120
C
C     Non-negative qd array: Update the e's
C
      DO 70 I = 1, N - 1
         EE( I ) = ( E( I ) / QQ( I ) )*Q( I+1 )
   70 CONTINUE
C
C     Updating sigma and iphase in ping
C
      SIGMA = SIGMA + TAU
      IPHASE = 2
   80 CONTINUE
      TOLX = SIGMA*TOL2
      TOLY = SIGMA*EPS
      TOLZ = MAX( SIGMA, SMALL2 )*TOL2
C
C     Checking for deflation and convergence (in ping)
C
   90 CONTINUE
      IF( N.LE.2 )
     $   RETURN
C
C        Deflation: bottom 1x1 (in ping)
C
      LDEF = .FALSE.
      IF( EE( N-1 ).LE.TOLZ ) THEN
         LDEF = .TRUE.
      ELSE IF( SIGMA.GT.ZERO ) THEN
         IF( EE( N-1 ).LE.EPS*( SIGMA+QQ( N ) ) ) THEN
            IF( EE( N-1 )*( QQ( N ) / ( QQ( N )+SIGMA ) ).LE.TOL2*
     $          ( QQ( N )+SIGMA ) ) THEN
               LDEF = .TRUE.
            END IF
         END IF
      ELSE
         IF( EE( N-1 ).LE.QQ( N )*TOL2 ) THEN
            LDEF = .TRUE.
         END IF
      END IF
      IF( LDEF ) THEN
         Q( N ) = QQ( N ) + SIGMA
         N = N - 1
         ICONV = ICONV + 1
         GO TO 90
      END IF
C
C        Deflation: bottom 2x2 (in ping)
C
      LDEF = .FALSE.
      IF( EE( N-2 ).LE.TOLZ ) THEN
         LDEF = .TRUE.
      ELSE IF( SIGMA.GT.ZERO ) THEN
         T1 = SIGMA + EE( N-1 )*( SIGMA / ( SIGMA+QQ( N ) ) )
         IF( EE( N-2 )*( T1 / ( QQ( N-1 )+T1 ) ).LE.TOLY ) THEN
            IF( EE( N-2 )*( QQ( N-1 ) / ( QQ( N-1 )+T1 ) ).LE.TOLX )
     $           THEN
               LDEF = .TRUE.
            END IF
         END IF
      ELSE
         IF( EE( N-2 ).LE.( QQ( N ) / ( QQ( N )+EE( N-1 )+QQ( N-1 ) ) )*
     $       QQ( N-1 )*TOL2 ) THEN
            LDEF = .TRUE.
         END IF
      END IF
      IF( LDEF ) THEN
         QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) )
         IF( QEMAX.NE.ZERO ) THEN
            IF( QEMAX.EQ.QQ( N-1 ) ) THEN
               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
     $              SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) /
     $              QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) )
            ELSE IF( QEMAX.EQ.QQ( N ) ) THEN
               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
     $              SQRT( ( ( QQ( N-1 )-QQ( N )+EE( N-1 ) ) /
     $              QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) )
            ELSE
               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
     $              SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) /
     $              QEMAX )**2+FOUR*QQ( N-1 ) / QEMAX ) )
            END IF
            YY = ( MAX( QQ( N ), QQ( N-1 ) ) / XX )*
     $           MIN( QQ( N ), QQ( N-1 ) )
         ELSE
            XX = ZERO
            YY = ZERO
         END IF
         Q( N-1 ) = SIGMA + XX
         Q( N ) = YY + SIGMA
         N = N - 2
         ICONV = ICONV + 2
         GO TO 90
      END IF
C
C     Updating bounds before going to pong
C
      IF( ICONV.EQ.0 ) THEN
         KEND = KE
         SUP = MIN( DM, SUP-TAU )
      ELSE IF( ICONV.GT.0 ) THEN
         SUP = MIN( QQ( N ), QQ( N-1 ), QQ( N-2 ), QQ( 1 ), QQ( 2 ),
     $         QQ( 3 ) )
         IF( ICONV.EQ.1 ) THEN
            KEND = K1END
         ELSE IF( ICONV.EQ.2 ) THEN
            KEND = K2END
         ELSE
            KEND = N
         END IF
         ICNT = 0
         MAXIT = 100*N
      END IF
C
C     Checking for splitting in ping
C
      LSPLIT = .FALSE.
      DO 100 KS = N - 3, 3, -1
         IF( EE( KS ).LE.TOLY ) THEN
            IF( EE( KS )*( MIN( QQ( KS+1 ),
     $          QQ( KS ) ) / ( MIN( QQ( KS+1 ), QQ( KS ) )+SIGMA ) ).LE.
     $          TOLX ) THEN
               LSPLIT = .TRUE.
               GO TO 110
            END IF
         END IF
  100 CONTINUE
C
      KS = 2
      IF( EE( 2 ).LE.TOLZ ) THEN
         LSPLIT = .TRUE.
      ELSE IF( SIGMA.GT.ZERO ) THEN
         T1 = SIGMA + EE( 1 )*( SIGMA / ( SIGMA+QQ( 1 ) ) )
         IF( EE( 2 )*( T1 / ( QQ( 1 )+T1 ) ).LE.TOLY ) THEN
            IF( EE( 2 )*( QQ( 1 ) / ( QQ( 1 )+T1 ) ).LE.TOLX ) THEN
               LSPLIT = .TRUE.
            END IF
         END IF
      ELSE
         IF( EE( 2 ).LE.( QQ( 1 ) / ( QQ( 1 )+EE( 1 )+QQ( 2 ) ) )*
     $       QQ( 2 )*TOL2 ) THEN
            LSPLIT = .TRUE.
         END IF
      END IF
      IF( LSPLIT )
     $   GO TO 110
C
      KS = 1
      IF( EE( 1 ).LE.TOLZ ) THEN
         LSPLIT = .TRUE.
      ELSE IF( SIGMA.GT.ZERO ) THEN
         IF( EE( 1 ).LE.EPS*( SIGMA+QQ( 1 ) ) ) THEN
            IF( EE( 1 )*( QQ( 1 ) / ( QQ( 1 )+SIGMA ) ).LE.TOL2*
     $          ( QQ( 1 )+SIGMA ) ) THEN
               LSPLIT = .TRUE.
            END IF
         END IF
      ELSE
         IF( EE( 1 ).LE.QQ( 1 )*TOL2 ) THEN
            LSPLIT = .TRUE.
         END IF
      END IF
C
  110 CONTINUE
      IF( LSPLIT ) THEN
         SUP = MIN( QQ( N ), QQ( N-1 ), QQ( N-2 ) )
         ISP = -( OFF+1 )
         OFF = OFF + KS
         N = N - KS
         KEND = MAX( 1, KEND-KS )
         E( KS ) = SIGMA
         EE( KS ) = ISP
         ICONV = 0
         RETURN
      END IF
C
C     Coincidence
C
      IF( TAU.EQ.ZERO .AND. DM.LE.TOLZ .AND. KEND.NE.N .AND. ICONV.EQ.
     $    0 .AND. ICNT.GT.0 ) THEN
         CALL GCopy( N-KE, E( KE ), 1, QQ( KE ), 1 )
         QQ( N ) = ZERO
         CALL GCopy( N-KE, Q( KE+1 ), 1, EE( KE ), 1 )
         SUP = ZERO
      END IF
      ICONV = 0
      GO TO 130
C
C     A new shift when the previous failed (in ping)
C
  120 CONTINUE
      IFL = IFL + 1
      SUP = TAU
C
C     SUP is small or
C     Too many bad shifts (ping)
C
      IF( SUP.LE.TOLZ .OR. IFL.GE.IFLMAX ) THEN
         TAU = ZERO
         GO TO 40
C
C     The asymptotic shift (in ping)
C
      ELSE
         TAU = MAX( TAU+D, ZERO )
         IF( TAU.LE.TOLZ )
     $      TAU = ZERO
         GO TO 40
      END IF
C
C     the pong section of the code
C
  130 CONTINUE
      IFL = 0
C
C     Compute the shift (in pong)
C
      IF( KEND.EQ.0 .AND. SUP.EQ.ZERO ) THEN
         TAU = ZERO
      ELSE IF( ICNT.GT.0 .AND. DM.LE.TOLZ ) THEN
         TAU = ZERO
      ELSE
         IP = MAX( IPP, N / NPP )
         N2 = 2*IP + 1
         IF( N2.GE.N ) THEN
            N1 = 1
            N2 = N
         ELSE IF( KEND+IP.GT.N ) THEN
            N1 = N - 2*IP
         ELSE IF( KEND-IP.LT.1 ) THEN
            N1 = 1
         ELSE
            N1 = KEND - IP
         END IF
         CALL DLASQ4( N2, QQ( N1 ), EE( N1 ), TAU, SUP )
      END IF
  140 CONTINUE
      ICNT = ICNT + 1
      IF( ICNT.GT.MAXIT ) THEN
         SUP = -SUP
         RETURN
      END IF
      IF( TAU.EQ.ZERO ) THEN
C
C     The dqd algorithm (in pong)
C
         D = QQ( 1 )
         DM = D
         KE = 0
         DO 150 I = 1, N - 3
            Q( I ) = D + EE( I )
            D = ( D / Q( I ) )*QQ( I+1 )
            IF( DM.GT.D ) THEN
               DM = D
               KE = I
            END IF
  150    CONTINUE
         KE = KE + 1
C
C     Penultimate dqd step (in pong)
C
         K2END = KE
         Q( N-2 ) = D + EE( N-2 )
         D = ( D / Q( N-2 ) )*QQ( N-1 )
         IF( DM.GT.D ) THEN
            DM = D
            KE = N - 1
         END IF
C
C     Final dqd step (in pong)
C
         K1END = KE
         Q( N-1 ) = D + EE( N-1 )
         D = ( D / Q( N-1 ) )*QQ( N )
         IF( DM.GT.D ) THEN
            DM = D
            KE = N
         END IF
         Q( N ) = D
      ELSE
C
C     The dqds algorithm (in pong)
C
         D = QQ( 1 ) - TAU
         DM = D
         KE = 0
         IF( D.LT.ZERO )
     $      GO TO 220
         DO 160 I = 1, N - 3
            Q( I ) = D + EE( I )
            D = ( D / Q( I ) )*QQ( I+1 ) - TAU
            IF( DM.GT.D ) THEN
               DM = D
               KE = I
               IF( D.LT.ZERO )
     $            GO TO 220
            END IF
  160    CONTINUE
         KE = KE + 1
C
C     Penultimate dqds step (in pong)
C
         K2END = KE
         Q( N-2 ) = D + EE( N-2 )
         D = ( D / Q( N-2 ) )*QQ( N-1 ) - TAU
         IF( DM.GT.D ) THEN
            DM = D
            KE = N - 1
            IF( D.LT.ZERO )
     $         GO TO 220
         END IF
C
C     Final dqds step (in pong)
C
         K1END = KE
         Q( N-1 ) = D + EE( N-1 )
         D = ( D / Q( N-1 ) )*QQ( N ) - TAU
         IF( DM.GT.D ) THEN
            DM = D
            KE = N
         END IF
         Q( N ) = D
      END IF
C
C        Convergence when is small (in pong)
C
      IF( ABS( Q( N ) ).LE.SIGMA*TOL2 ) THEN
         Q( N ) = ZERO
         DM = ZERO
         KE = N
      END IF
      IF( Q( N ).LT.ZERO )
     $   GO TO 220
C
C     Non-negative qd array: Update the e's
C
      DO 170 I = 1, N - 1
         E( I ) = ( EE( I ) / Q( I ) )*QQ( I+1 )
  170 CONTINUE
C
C     Updating sigma and iphase in pong
C
      SIGMA = SIGMA + TAU
  180 CONTINUE
      IPHASE = 1
      TOLX = SIGMA*TOL2
      TOLY = SIGMA*EPS
C
C     Checking for deflation and convergence (in pong)
C
  190 CONTINUE
      IF( N.LE.2 )
     $   RETURN
C
C        Deflation: bottom 1x1 (in pong)
C
      LDEF = .FALSE.
      IF( E( N-1 ).LE.TOLZ ) THEN
         LDEF = .TRUE.
      ELSE IF( SIGMA.GT.ZERO ) THEN
         IF( E( N-1 ).LE.EPS*( SIGMA+Q( N ) ) ) THEN
            IF( E( N-1 )*( Q( N ) / ( Q( N )+SIGMA ) ).LE.TOL2*
     $          ( Q( N )+SIGMA ) ) THEN
               LDEF = .TRUE.
            END IF
         END IF
      ELSE
         IF( E( N-1 ).LE.Q( N )*TOL2 ) THEN
            LDEF = .TRUE.
         END IF
      END IF
      IF( LDEF ) THEN
         Q( N ) = Q( N ) + SIGMA
         N = N - 1
         ICONV = ICONV + 1
         GO TO 190
      END IF
C
C        Deflation: bottom 2x2 (in pong)
C
      LDEF = .FALSE.
      IF( E( N-2 ).LE.TOLZ ) THEN
         LDEF = .TRUE.
      ELSE IF( SIGMA.GT.ZERO ) THEN
         T1 = SIGMA + E( N-1 )*( SIGMA / ( SIGMA+Q( N ) ) )
         IF( E( N-2 )*( T1 / ( Q( N-1 )+T1 ) ).LE.TOLY ) THEN
            IF( E( N-2 )*( Q( N-1 ) / ( Q( N-1 )+T1 ) ).LE.TOLX ) THEN
               LDEF = .TRUE.
            END IF
         END IF
      ELSE
         IF( E( N-2 ).LE.( Q( N ) / ( Q( N )+EE( N-1 )+Q( N-1 ) )*Q( N-
     $       1 ) )*TOL2 ) THEN
            LDEF = .TRUE.
         END IF
      END IF
      IF( LDEF ) THEN
         QEMAX = MAX( Q( N ), Q( N-1 ), E( N-1 ) )
         IF( QEMAX.NE.ZERO ) THEN
            IF( QEMAX.EQ.Q( N-1 ) ) THEN
               XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX*
     $              SQRT( ( ( Q( N )-Q( N-1 )+E( N-1 ) ) / QEMAX )**2+
     $              FOUR*E( N-1 ) / QEMAX ) )
            ELSE IF( QEMAX.EQ.Q( N ) ) THEN
               XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX*
     $              SQRT( ( ( Q( N-1 )-Q( N )+E( N-1 ) ) / QEMAX )**2+
     $              FOUR*E( N-1 ) / QEMAX ) )
            ELSE
               XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX*
     $              SQRT( ( ( Q( N )-Q( N-1 )+E( N-1 ) ) / QEMAX )**2+
     $              FOUR*Q( N-1 ) / QEMAX ) )
            END IF
            YY = ( MAX( Q( N ), Q( N-1 ) ) / XX )*
     $           MIN( Q( N ), Q( N-1 ) )
         ELSE
            XX = ZERO
            YY = ZERO
         END IF
         Q( N-1 ) = SIGMA + XX
         Q( N ) = YY + SIGMA
         N = N - 2
         ICONV = ICONV + 2
         GO TO 190
      END IF
C
C     Updating bounds before going to pong
C
      IF( ICONV.EQ.0 ) THEN
         KEND = KE
         SUP = MIN( DM, SUP-TAU )
      ELSE IF( ICONV.GT.0 ) THEN
         SUP = MIN( Q( N ), Q( N-1 ), Q( N-2 ), Q( 1 ), Q( 2 ), Q( 3 ) )
         IF( ICONV.EQ.1 ) THEN
            KEND = K1END
         ELSE IF( ICONV.EQ.2 ) THEN
            KEND = K2END
         ELSE
            KEND = N
         END IF
         ICNT = 0
         MAXIT = 100*N
      END IF
C
C     Checking for splitting in pong
C
      LSPLIT = .FALSE.
      DO 200 KS = N - 3, 3, -1
         IF( E( KS ).LE.TOLY ) THEN
            IF( E( KS )*( MIN( Q( KS+1 ), Q( KS ) ) / ( MIN( Q( KS+1 ),
     $          Q( KS ) )+SIGMA ) ).LE.TOLX ) THEN
               LSPLIT = .TRUE.
               GO TO 210
            END IF
         END IF
  200 CONTINUE
C
      KS = 2
      IF( E( 2 ).LE.TOLZ ) THEN
         LSPLIT = .TRUE.
      ELSE IF( SIGMA.GT.ZERO ) THEN
         T1 = SIGMA + E( 1 )*( SIGMA / ( SIGMA+Q( 1 ) ) )
         IF( E( 2 )*( T1 / ( Q( 1 )+T1 ) ).LE.TOLY ) THEN
            IF( E( 2 )*( Q( 1 ) / ( Q( 1 )+T1 ) ).LE.TOLX ) THEN
               LSPLIT = .TRUE.
            END IF
         END IF
      ELSE
         IF( E( 2 ).LE.( Q( 1 ) / ( Q( 1 )+E( 1 )+Q( 2 ) ) )*Q( 2 )*
     $       TOL2 ) THEN
            LSPLIT = .TRUE.
         END IF
      END IF
      IF( LSPLIT )
     $   GO TO 210
C
      KS = 1
      IF( E( 1 ).LE.TOLZ ) THEN
         LSPLIT = .TRUE.
      ELSE IF( SIGMA.GT.ZERO ) THEN
         IF( E( 1 ).LE.EPS*( SIGMA+Q( 1 ) ) ) THEN
            IF( E( 1 )*( Q( 1 ) / ( Q( 1 )+SIGMA ) ).LE.TOL2*
     $          ( Q( 1 )+SIGMA ) ) THEN
               LSPLIT = .TRUE.
            END IF
         END IF
      ELSE
         IF( E( 1 ).LE.Q( 1 )*TOL2 ) THEN
            LSPLIT = .TRUE.
         END IF
      END IF
C
  210 CONTINUE
      IF( LSPLIT ) THEN
         SUP = MIN( Q( N ), Q( N-1 ), Q( N-2 ) )
         ISP = OFF + 1
         OFF = OFF + KS
         KEND = MAX( 1, KEND-KS )
         N = N - KS
         E( KS ) = SIGMA
         EE( KS ) = ISP
         ICONV = 0
         RETURN
      END IF
C
C     Coincidence
C
      IF( TAU.EQ.ZERO .AND. DM.LE.TOLZ .AND. KEND.NE.N .AND. ICONV.EQ.
     $    0 .AND. ICNT.GT.0 ) THEN
         CALL GCopy( N-KE, EE( KE ), 1, Q( KE ), 1 )
         Q( N ) = ZERO
         CALL GCopy( N-KE, QQ( KE+1 ), 1, E( KE ), 1 )
         SUP = ZERO
      END IF
      ICONV = 0
      GO TO 30
C
C     Computation of a new shift when the previous failed (in pong)
C
  220 CONTINUE
      IFL = IFL + 1
      SUP = TAU
C
C     SUP is small or
C     Too many bad shifts (in pong)
C
      IF( SUP.LE.TOLZ .OR. IFL.GE.IFLMAX ) THEN
         TAU = ZERO
         GO TO 140
C
C     The asymptotic shift (in pong)
C
      ELSE
         TAU = MAX( TAU+D, ZERO )
         IF( TAU.LE.TOLZ )
     $      TAU = ZERO
         GO TO 140
      END IF
      END
*Deck DLASQ4
      SUBROUTINE DLASQ4( N, Q, E, TAU, SUP )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            N
      Real*8   SUP, TAU
C     ..
C     .. Array Arguments ..
      Real*8   E( * ), Q( * )
C     ..
C
C     Purpose
C     =======
C
C     DLASQ4 estimates TAU, the smallest eigenvalue of a matrix. This
C     routine improves the input value of SUP which is an upper bound
C     for the smallest eigenvalue for this matrix .
C
C     Arguments
C     =========
C
C  N       (input) INTEGER
C          On entry, N specifies the number of rows and columns
C          in the matrix. N must be at least 0.
C
C  Q       (input) Real*8 array, dimension (N)
C          Q array
C
C  E       (input) Real*8 array, dimension (N)
C          E array
C
C  TAU     (output) Real*8
C          Estimate of the shift
C
C  SUP     (input/output) Real*8
C          Upper bound for the smallest singular value
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      Real*8   BIS, BIS1
      PARAMETER          ( BIS = 0.9999D+0, BIS1 = 0.7D+0 )
      INTEGER            IFLMAX
      PARAMETER          ( IFLMAX = 5 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IFL
      Real*8   D, DM, XINF
C     ..
C     .. Executable Statements ..
      IFL = 1
      SUP = MIN( SUP, Q( 1 ), Q( 2 ), Q( 3 ), Q( N ), Q( N-1 ),
     $      Q( N-2 ) )
      TAU = SUP*BIS
      XINF = ZERO
   10 CONTINUE
      IF( IFL.EQ.IFLMAX ) THEN
         TAU = XINF
         RETURN
      END IF
      D = Q( 1 ) - TAU
      DM = D
      DO 20 I = 1, N - 2
         D = ( D / ( D+E( I ) ) )*Q( I+1 ) - TAU
         IF( DM.GT.D )
     $      DM = D
         IF( D.LT.ZERO ) THEN
            SUP = TAU
            TAU = MAX( SUP*BIS1**IFL, D+TAU )
            IFL = IFL + 1
            GO TO 10
         END IF
   20 CONTINUE
      D = ( D / ( D+E( N-1 ) ) )*Q( N ) - TAU
      IF( DM.GT.D )
     $   DM = D
      IF( D.LT.ZERO ) THEN
         SUP = TAU
         XINF = MAX( XINF, D+TAU )
         IF( SUP*BIS1**IFL.LE.XINF ) THEN
            TAU = XINF
         ELSE
            TAU = SUP*BIS1**IFL
            IFL = IFL + 1
            GO TO 10
         END IF
      ELSE
         SUP = MIN( SUP, DM+TAU )
      END IF
      RETURN
      END
*Deck DLASR
      SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          DIRECT, PIVOT, SIDE
      INTEGER            LDA, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), C( * ), S( * )
C     ..
C
C  Purpose
C  =======
C
C  DLASR   performs the transformation
C
C     A := P*A,   when SIDE = 'L' or 'l'  (  Left-hand side )
C
C     A := A*P',  when SIDE = 'R' or 'r'  ( Right-hand side )
C
C  where A is an m by n real matrix and P is an orthogonal matrix,
C  consisting of a sequence of plane rotations determined by the
C  parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l'
C  and z = n when SIDE = 'R' or 'r' ):
C
C  When  DIRECT = 'F' or 'f'  ( Forward sequence ) then
C
C     P = P( z - 1 )*...*P( 2 )*P( 1 ),
C
C  and when DIRECT = 'B' or 'b'  ( Backward sequence ) then
C
C     P = P( 1 )*P( 2 )*...*P( z - 1 ),
C
C  where  P( k ) is a plane rotation matrix for the following planes:
C
C     when  PIVOT = 'V' or 'v'  ( Variable pivot ),
C        the plane ( k, k + 1 )
C
C     when  PIVOT = 'T' or 't'  ( Top pivot ),
C        the plane ( 1, k + 1 )
C
C     when  PIVOT = 'B' or 'b'  ( Bottom pivot ),
C        the plane ( k, z )
C
C  c( k ) and s( k )  must contain the  cosine and sine that define the
C  matrix  P( k ).  The two by two plane rotation part of the matrix
C  P( k ), R( k ), is assumed to be of the form
C
C     R( k ) = (  c( k )  s( k ) ).
C              ( -s( k )  c( k ) )
C
C  This version vectorises across rows of the array A when SIDE = 'L'.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          Specifies whether the plane rotation matrix P is applied to
C          A on the left or the right.
C          = 'L':  Left, compute A := P*A
C          = 'R':  Right, compute A:= A*P'
C
C  DIRECT  (input) CHARACTER*1
C          Specifies whether P is a forward or backward sequence of
C          plane rotations.
C          = 'F':  Forward, P = P( z - 1 )*...*P( 2 )*P( 1 )
C          = 'B':  Backward, P = P( 1 )*P( 2 )*...*P( z - 1 )
C
C  PIVOT   (input) CHARACTER*1
C          Specifies the plane for which P(k) is a plane rotation
C          matrix.
C          = 'V':  Variable pivot, the plane (k,k+1)
C          = 'T':  Top pivot, the plane (1,k+1)
C          = 'B':  Bottom pivot, the plane (k,z)
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  If m <= 1, an immediate
C          return is effected.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  If n <= 1, an
C          immediate return is effected.
C
C  C, S    (input) Real*8 arrays, dimension
C                  (M-1) if SIDE = 'L'
C                  (N-1) if SIDE = 'R'
C          c(k) and s(k) contain the cosine and sine that define the
C          matrix P(k).  The two by two plane rotation part of the
C          matrix P(k), R(k), is assumed to be of the form
C          R( k ) = (  c( k )  s( k ) ).
C                   ( -s( k )  c( k ) )
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          The m by n matrix A.  On exit, A is overwritten by P*A if
C          SIDE = 'R' or by A*P' if SIDE = 'L'.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, INFO, J
      Real*8   CTEMP, STEMP, TEMP
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters
C
      INFO = 0
      IF( .NOT.( GLSame( SIDE, 'L' ) .OR. GLSame( SIDE, 'R' ) ) ) THEN
         INFO = 1
      ELSE IF( .NOT.( GLSame( PIVOT, 'V' ) .OR. GLSame( PIVOT,
     $         'T' ) .OR. GLSame( PIVOT, 'B' ) ) ) THEN
         INFO = 2
      ELSE IF(.NOT.(GLSame(DIRECT,'F').OR.GLSame(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) Call GLBErr('DLASR',Info)
C
C     Quick return if possible
C
      If(M.eq.0.or.N.eq.0) RETURN
      IF( GLSame( SIDE, 'L' ) ) THEN
C
C        Form  P * A
C
         IF( GLSame( PIVOT, 'V' ) ) THEN
            IF( GLSame( 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( GLSame( 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( GLSame( PIVOT, 'T' ) ) THEN
            IF( GLSame( 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( GLSame( 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( GLSame( PIVOT, 'B' ) ) THEN
            IF( GLSame( 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( GLSame( 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( GLSame( SIDE, 'R' ) ) THEN
C
C        Form A * P'
C
         IF( GLSame( PIVOT, 'V' ) ) THEN
            IF( GLSame( 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( GLSame( 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( GLSame( PIVOT, 'T' ) ) THEN
            IF( GLSame( 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( GLSame( 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( GLSame( PIVOT, 'B' ) ) THEN
            IF( GLSame( 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( GLSame( 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
C
      RETURN
      END
*Deck DLASRT
      SUBROUTINE DLASRT( ID, N, D, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          ID
      INTEGER            INFO, N
C     ..
C     .. Array Arguments ..
      Real*8   D( * )
C     ..
C
C  Purpose
C  =======
C
C  Sort the numbers in D in increasing order (if ID = 'I') or
C  in decreasing order (if ID = 'D' ).
C
C  Use Quick Sort, reverting to Insertion sort on arrays of
C  size <= 20. Dimension of STACK limits N to about 2**32.
C
C  Arguments
C  =========
C
C  ID      (input) CHARACTER*1
C          = 'I': sort D in increasing order;
C          = 'D': sort D in decreasing order.
C
C  N       (input) INTEGER
C          The length of the array D.
C
C  D       (input/output) Real*8 array, dimension (N)
C          On entry, the array to be sorted.
C          On exit, D has been sorted into increasing order
C          (D(1) <= ... <= D(N) ) or into decreasing order
C          (D(1) >= ... >= D(N) ), depending on ID.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      INTEGER            SELECT
      PARAMETER          ( SELECT = 20 )
C     ..
C     .. Local Scalars ..
      INTEGER            DIR, ENDD, I, J, START, STKPNT
      Real*8   D1, D2, D3, DMNMX, TMP
C     ..
C     .. Local Arrays ..
      INTEGER            STACK( 2, 32 )
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input paramters.
C
      INFO = 0
      DIR = -1
      IF( GLSame( ID, 'D' ) ) THEN
         DIR = 0
      ELSE IF( GLSame( 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) Call GLBErr('DLASRT',Info)
      If(N.le.1) RETURN
C
      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
C
C        Do Insertion sort on D( START:ENDD )
C
         IF( DIR.EQ.0 ) THEN
C
C           Sort into decreasing order
C
            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
C
         ELSE
C
C           Sort into increasing order
C
            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
C
         END IF
C
      ELSE IF( ENDD-START.GT.SELECT ) THEN
C
C        Partition D( START:ENDD ) and stack parts, largest one first
C
C        Choose partition entry as median of 3
C
         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
C
         IF( DIR.EQ.0 ) THEN
C
C           Sort into decreasing order
C
            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
C
C           Sort into increasing order
C
            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
*Deck DLASSQ
      SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INCX, N
      Real*8   SCALE, SUMSQ
C     ..
C     .. Array Arguments ..
      Real*8   X( * )
C     ..
C
C  Purpose
C  =======
C
C  DLASSQ  returns the values  scl  and  smsq  such that
C
C     ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
C
C  where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
C  assumed to be non-negative and  scl  returns the value
C
C     scl = max( scale, abs( x( i ) ) ).
C
C  scale and sumsq must be supplied in SCALE and SUMSQ and
C  scl and smsq are overwritten on SCALE and SUMSQ respectively.
C
C  The routine makes only one pass through the vector x.
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The number of elements to be used from the vector X.
C
C  X       (input) Real*8
C          The vector for which a scaled sum of squares is computed.
C             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
C
C  INCX    (input) INTEGER
C          The increment between successive values of the vector X.
C          INCX > 0.
C
C  SCALE   (input/output) Real*8
C          On entry, the value  scale  in the equation above.
C          On exit, SCALE is overwritten with  scl , the scaling factor
C          for the sum of squares.
C
C  SUMSQ   (input/output) Real*8
C          On entry, the value  sumsq  in the equation above.
C          On exit, SUMSQ is overwritten with  smsq , the basic sum of
C          squares from which  scl  has been factored out.
C
C =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            IX
      Real*8   ABSXI
C     ..
C     .. Executable Statements ..
C
      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
*Deck DLASV2
      SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
      Real*8   CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  DLASV2 computes the singular value decomposition of a 2-by-2
C  triangular matrix
C     [  F   G  ]
C     [  0   H  ].
C  On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
C  smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
C  right singular vectors for abs(SSMAX), giving the decomposition
C
C     [ CSL  SNL ] [  F   G  ] [ CSR -SNR ]  =  [ SSMAX   0   ]
C     [-SNL  CSL ] [  0   H  ] [ SNR  CSR ]     [  0    SSMIN ].
C
C  Arguments
C  =========
C
C  F       (input) Real*8
C          The (1,1) element of the 2-by-2 matrix.
C
C  G       (input) Real*8
C          The (1,2) element of the 2-by-2 matrix.
C
C  H       (input) Real*8
C          The (2,2) element of the 2-by-2 matrix.
C
C  SSMIN   (output) Real*8
C          abs(SSMIN) is the smaller singular value.
C
C  SSMAX   (output) Real*8
C          abs(SSMAX) is the larger singular value.
C
C  SNL     (output) Real*8
C  CSL     (output) Real*8
C          The vector (CSL, SNL) is a unit left singular vector for the
C          singular value abs(SSMAX).
C
C  SNR     (output) Real*8
C  CSR     (output) Real*8
C          The vector (CSR, SNR) is a unit right singular vector for the
C          singular value abs(SSMAX).
C
C  Further Details
C  ===============
C
C  Any input parameter may be aliased with any output parameter.
C
C  Barring over/underflow and assuming a guard digit in subtraction, all
C  output quantities are correct to within a few units in the last
C  place (ulps).
C
C  In IEEE arithmetic, the code works correctly if one matrix element is
C  infinite.
C
C  Overflow will not occur unless the largest singular value itself
C  overflows or is within a few ulps of overflow. (On machines with
C  partial overflow, like the Cray, overflow may occur if the largest
C  singular value is within a factor of 2 of overflow.)
C
C  Underflow is harmless if underflow is gradual. Otherwise, results
C  may correspond to a matrix modified by perturbations of size near
C  the underflow threshold.
C
C =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      Real*8   HALF
      PARAMETER          ( HALF = 0.5D0 )
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D0 )
      Real*8   TWO
      PARAMETER          ( TWO = 2.0D0 )
      Real*8   FOUR
      PARAMETER          ( FOUR = 4.0D0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            GASMAL, SWAP
      INTEGER            PMAX
      Real*8   A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M,
     $                   MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT
C     ..
C     .. Executable Statements ..
C
      FT = F
      FA = ABS( FT )
      HT = H
      HA = ABS( H )
C
C     PMAX points to the maximum absolute element of matrix
C       PMAX = 1 if F largest in absolute values
C       PMAX = 2 if G largest in absolute values
C       PMAX = 3 if H largest in absolute values
C
      PMAX = 1
      SWAP = ( HA.GT.FA )
      IF( SWAP ) THEN
         PMAX = 3
         TEMP = FT
         FT = HT
         HT = TEMP
         TEMP = FA
         FA = HA
         HA = TEMP
C
C        Now FA .ge. HA
C
      END IF
      GT = G
      GA = ABS( GT )
      IF( GA.EQ.ZERO ) THEN
C
C        Diagonal matrix
C
         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.EPS) THEN
C
C              Case of very large GA
C
               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
C
C           Normal case
C
            D = FA - HA
            IF( D.EQ.FA ) THEN
C
C              Copes with infinite F or H
C
               L = ONE
            ELSE
               L = D / FA
            END IF
C
C           Note that 0 .le. L .le. 1
C
            M = GT / FT
C
C           Note that abs(M) .le. 1/macheps
C
            T = TWO - L
C
C           Note that T .ge. 1
C
            MM = M*M
            TT = T*T
            S = SQRT( TT+MM )
C
C           Note that 1 .le. S .le. 1 + 1/macheps
C
            IF( L.EQ.ZERO ) THEN
               R = ABS( M )
            ELSE
               R = SQRT( L*L+MM )
            END IF
C
C           Note that 0 .le. R .le. 1 + 1/macheps
C
            A = HALF*( S+R )
C
C           Note that 1 .le. A .le. 1 + abs(M)
C
            SSMIN = HA / A
            SSMAX = FA*A
            IF( MM.EQ.ZERO ) THEN
C
C              Note that M is very tiny
C
               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
C
C     Correct signs of SSMAX and SSMIN
C
      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
*Deck DLASWP
      SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      Real*8   A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  DLASWP performs a series of row interchanges on the matrix A.
C  One row interchange is initiated for each of rows K1 through K2 of A.
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the matrix of column dimension N to which the row
C          interchanges will be applied.
C          On exit, the permuted matrix.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.
C
C  K1      (input) INTEGER
C          The first element of IPIV for which a row interchange will
C          be done.
C
C  K2      (input) INTEGER
C          The last element of IPIV for which a row interchange will
C          be done.
C
C  IPIV    (input) INTEGER array, dimension (M*abs(INCX))
C          The vector of pivot indices.  Only the elements in positions
C          K1 through K2 of IPIV are accessed.
C          IPIV(K) = L implies rows K and L are to be interchanged.
C
C  INCX    (input) INTEGER
C          The increment between successive values of IPIV.  If IPIV
C          is negative, the pivots are applied in reverse order.
C
C =====================================================================
C
C     Interchange row I with row IPIV(I) for each of rows K1 through K2.
C
      IF( INCX.EQ.0 )
     $   RETURN
      IF( INCX.GT.0 ) THEN
         IX = K1
      ELSE
         IX = 1 + ( 1-K2 )*INCX
      END IF
      IF( INCX.EQ.1 ) THEN
         DO 10 I = K1, K2
            IP = IPIV( I )
            IF( IP.NE.I )
     $         CALL GSwap( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
   10    CONTINUE
      ELSE IF( INCX.GT.1 ) THEN
         DO 20 I = K1, K2
            IP = IPIV( IX )
            IF( IP.NE.I )
     $         CALL GSwap( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
            IX = IX + INCX
   20    CONTINUE
      ELSE IF( INCX.LT.0 ) THEN
         DO 30 I = K2, K1, -1
            IP = IPIV( IX )
            IF( IP.NE.I )
     $         CALL GSwap( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
            IX = IX + INCX
   30    CONTINUE
      END IF
      RETURN
      END
*Deck DOPGTR
      SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDQ, N
C     ..
C     .. Array Arguments ..
      Real*8   AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DOPGTR generates a real orthogonal matrix Q which is defined as the
C  product of n-1 elementary reflectors H(i) of order n, as returned by
C  DSPTRD using packed storage:
C
C  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
C
C  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          = 'U': Upper triangular packed storage used in previous
C                 call to DSPTRD;
C          = 'L': Lower triangular packed storage used in previous
C                 call to DSPTRD.
C
C  N       (input) INTEGER
C          The order of the matrix Q. N >= 0.
C
C  AP      (input) Real*8 array, dimension (N*(N+1)/2)
C          The vectors which define the elementary reflectors, as
C          returned by DSPTRD.
C
C  TAU     (input) Real*8 array, dimension (N-1)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DSPTRD.
C
C  Q       (output) Real*8 array, dimension (LDQ,N)
C          The N-by-N orthogonal matrix Q.
C
C  LDQ     (input) INTEGER
C          The leading dimension of the array Q. LDQ >= max(1,N).
C
C  WORK    (workspace) Real*8 array, dimension (N-1)
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IINFO, IJ, J
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      UPPER = GLSame( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.GLSame( 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) Call GLBErr('DOPGTR',Info)
      If(N.eq.0) RETURN
      IF( UPPER ) THEN
C
C        Q was determined by a call to DSPTRD with UPLO = 'U'
C
C        Unpack the vectors which define the elementary reflectors and
C        set the last row and column of Q equal to those of the unit
C        matrix
C
         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
C
C        Generate Q(1:n-1,1:n-1)
C
         CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
C
      ELSE
C
C        Q was determined by a call to DSPTRD with UPLO = 'L'.
C
C        Unpack the vectors which define the elementary reflectors and
C        set the first row and column of Q equal to those of the unit
C        matrix
C
         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
C
C           Generate Q(2:n,2:n)
C
            CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
     $                   IINFO )
         END IF
      END IF
      RETURN
      END
*Deck DORG2L
      SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DORG2L generates an m by n real matrix Q with orthonormal columns,
C  which is defined as the last n columns of a product of k elementary
C  reflectors of order m
C
C        Q  =  H(k) . . . H(2) H(1)
C
C  as returned by DGEQLF.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q. M >= N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines the
C          matrix Q. N >= K >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the (n-k+i)-th column must contain the vector which
C          defines the elementary reflector H(i), for i = 1,2,...,k, as
C          returned by DGEQLF in the last k columns of its array
C          argument A.
C          On exit, the m by n matrix Q.
C
C  LDA     (input) INTEGER
C          The first dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) Real*8 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DGEQLF.
C
C  WORK    (workspace) Real*8 array, dimension (N)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument has an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, II, J, L
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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) Call GLBErr('DORG2L',Info)
      If(N.le.0) RETURN
C
C     Initialise columns 1:n-k to columns of the unit matrix
C
      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
C
      DO 40 I = 1, K
         II = N - K + I
C
C        Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
C
         A( M-N+II, II ) = ONE
         CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
     $               LDA, WORK )
         CALL GScal( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
         A( M-N+II, II ) = ONE - TAU( I )
C
C        Set A(m-k+i+1:m,n-k+i) to zero
C
         DO 30 L = M - N + II + 1, M
            A( L, II ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
*Deck DORG2R
      SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DORG2R generates an m by n real matrix Q with orthonormal columns,
C  which is defined as the first n columns of a product of k elementary
C  reflectors of order m
C
C        Q  =  H(1) H(2) . . . H(k)
C
C  as returned by DGEQRF.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q. M >= N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines the
C          matrix Q. N >= K >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the i-th column must contain the vector which
C          defines the elementary reflector H(i), for i = 1,2,...,k, as
C          returned by DGEQRF in the first k columns of its array
C          argument A.
C          On exit, the m-by-n matrix Q.
C
C  LDA     (input) INTEGER
C          The first dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) Real*8 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DGEQRF.
C
C  WORK    (workspace) Real*8 array, dimension (N)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument has an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, J, L
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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) Call GLBErr('DORG2R',Info)
      If(N.le.0) RETURN
C
C     Initialise columns k+1:n to columns of the unit matrix
C
      DO 20 J = K + 1, N
         DO 10 L = 1, M
            A( L, J ) = ZERO
   10    CONTINUE
         A( J, J ) = ONE
   20 CONTINUE
C
      DO 40 I = K, 1, -1
C
C        Apply H(i) to A(i:m,i:n) from the left
C
         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 GScal( M-I, -TAU( I ), A( I+1, I ), 1 )
         A( I, I ) = ONE - TAU( I )
C
C        Set A(1:i-1,i) to zero
C
         DO 30 L = 1, I - 1
            A( L, I ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
*Deck DORGBR
      SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          VECT
      INTEGER            INFO, K, LDA, LWORK, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), TAU( * ), WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  DORGBR generates one of the real orthogonal matrices Q or P**T
C  determined by DGEBRD when reducing a real matrix A to bidiagonal
C  form: A = Q * B * P**T.  Q and P**T are defined as products of
C  elementary reflectors H(i) or G(i) respectively.
C
C  If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
C  is of order M:
C  if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n
C  columns of Q, where m >= n >= k;
C  if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an
C  M-by-M matrix.
C
C  If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T
C  is of order N:
C  if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m
C  rows of P**T, where n >= m >= k;
C  if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as
C  an N-by-N matrix.
C
C  Arguments
C  =========
C
C  VECT    (input) CHARACTER*1
C          Specifies whether the matrix Q or the matrix P**T is
C          required, as defined in the transformation applied by DGEBRD:
C          = 'Q':  generate Q;
C          = 'P':  generate P**T.
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q or P**T to be returned.
C          M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q or P**T to be returned.
C          N >= 0.
C          If VECT = 'Q', M >= N >= min(M,K);
C          if VECT = 'P', N >= M >= min(N,K).
C
C  K       (input) INTEGER
C          If VECT = 'Q', the number of columns in the original M-by-K
C          matrix reduced by DGEBRD.
C          If VECT = 'P', the number of rows in the original K-by-N
C          matrix reduced by DGEBRD.
C          K >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the vectors which define the elementary reflectors,
C          as returned by DGEBRD.
C          On exit, the M-by-N matrix Q or P**T.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) Real*8 array, dimension
C                                (min(M,K)) if VECT = 'Q'
C                                (min(N,K)) if VECT = 'P'
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i) or G(i), which determines Q or P**T, as
C          returned by DGEBRD in its array argument TAUQ or TAUP.
C
C  WORK    (workspace/output) Real*8 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK. LWORK >= max(1,min(M,N)).
C          For optimum performance LWORK >= min(M,N)*NB, where NB
C          is the optimal blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            WANTQ
      INTEGER            I, IINFO, J
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      WANTQ = GLSame( VECT, 'Q' )
      IF( .NOT.WANTQ .AND. .NOT.GLSame( 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, MIN( M, N ) ) ) THEN
         INFO = -9
      END IF
      If(Info.ne.0) Call GLBErr('DORGBR',Info)
C
C     Quick return if possible
C
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
C
      IF( WANTQ ) THEN
C
C        Form Q, determined by a call to DGEBRD to reduce an m-by-k
C        matrix
C
         IF( M.GE.K ) THEN
C
C           If m >= k, assume m >= n >= k
C
            CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
C
         ELSE
C
C           If m < k, assume m = n
C
C           Shift the vectors which define the elementary reflectors one
C           column to the right, and set the first row and column of Q
C           to those of the unit matrix
C
            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
C
C              Form Q(2:m,2:m)
C
               CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
     $                      LWORK, IINFO )
            END IF
         END IF
      ELSE
C
C        Form P', determined by a call to DGEBRD to reduce a k-by-n
C        matrix
C
         IF( K.LT.N ) THEN
C
C           If k < n, assume k <= m <= n
C
            CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
C
         ELSE
C
C           If k >= n, assume m = n
C
C           Shift the vectors which define the elementary reflectors one
C           row downward, and set the first row and column of P' to
C           those of the unit matrix
C
            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
C
C              Form P'(2:n,2:n)
C
               CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
     $                      LWORK, IINFO )
            END IF
         END IF
      END IF
      RETURN
      END
*Deck DORGL2
      SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DORGL2 generates an m by n real matrix Q with orthonormal rows,
C  which is defined as the first m rows of a product of k elementary
C  reflectors of order n
C
C        Q  =  H(k) . . . H(2) H(1)
C
C  as returned by DGELQF.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q. N >= M.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines the
C          matrix Q. M >= K >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the i-th row must contain the vector which defines
C          the elementary reflector H(i), for i = 1,2,...,k, as returned
C          by DGELQF in the first k rows of its array argument A.
C          On exit, the m-by-n matrix Q.
C
C  LDA     (input) INTEGER
C          The first dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) Real*8 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DGELQF.
C
C  WORK    (workspace) Real*8 array, dimension (M)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument has an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, J, L
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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) Call GLBErr('DORGL2',Info)
      If(M.le.0) RETURN
      IF( K.LT.M ) THEN
C
C        Initialise rows k+1:m to rows of the unit matrix
C
         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
C
      DO 40 I = K, 1, -1
C
C        Apply H(i) to A(i:m,i:n) from the right
C
         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 GScal( N-I, -TAU( I ), A( I, I+1 ), LDA )
         END IF
         A( I, I ) = ONE - TAU( I )
C
C        Set A(1:i-1,i) to zero
C
         DO 30 L = 1, I - 1
            A( I, L ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
*Deck DORGLQ
      SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, LWORK, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), TAU( * ), WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  DORGLQ generates an M-by-N real matrix Q with orthonormal rows,
C  which is defined as the first M rows of a product of K elementary
C  reflectors of order N
C
C        Q  =  H(k) . . . H(2) H(1)
C
C  as returned by DGELQF.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q. N >= M.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines the
C          matrix Q. M >= K >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the i-th row must contain the vector which defines
C          the elementary reflector H(i), for i = 1,2,...,k, as returned
C          by DGELQF in the first k rows of its array argument A.
C          On exit, the M-by-N matrix Q.
C
C  LDA     (input) INTEGER
C          The first dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) Real*8 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DGELQF.
C
C  WORK    (workspace/output) Real*8 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK. LWORK >= max(1,M).
C          For optimum performance LWORK >= M*NB, where NB is
C          the optimal blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument has an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB,
     $                   NBMIN, NX
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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
      ELSE IF( LWORK.LT.MAX( 1, M ) ) THEN
         INFO = -8
      END IF
      If(Info.ne.0) Call GLBErr('DORGLQ',Info)
C
C     Quick return if possible
C
      IF( M.LE.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
C
C     Determine the block size.
C
      NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 )
      NBMIN = 2
      NX = 0
      IWS = M
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
C
C        Determine when to cross over from blocked to unblocked code.
C
         NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) )
         IF( NX.LT.K ) THEN
C
C           Determine if workspace is large enough for blocked code.
C
            LDWORK = M
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
C
C              Not enough workspace to use optimal NB:  reduce NB and
C              determine the minimum value of NB.
C
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DORGLQ', ' ', M, N, K, -1 ) )
            END IF
         END IF
      END IF
C
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
C
C        Use blocked code after the last block.
C        The first kk rows are handled by the block method.
C
         KI = ( ( K-NX-1 ) / NB )*NB
         KK = MIN( K, KI+NB )
C
C        Set A(kk+1:m,1:kk) to zero.
C
         DO 20 J = 1, KK
            DO 10 I = KK + 1, M
               A( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
      ELSE
         KK = 0
      END IF
C
C     Use unblocked code for the last or only block.
C
      IF( KK.LT.M )
     $   CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
     $                TAU( KK+1 ), WORK, IINFO )
C
      IF( KK.GT.0 ) THEN
C
C        Use blocked code
C
         DO 50 I = KI + 1, 1, -NB
            IB = MIN( NB, K-I+1 )
            IF( I+IB.LE.M ) THEN
C
C              Form the triangular factor of the block reflector
C              H = H(i) H(i+1) . . . H(i+ib-1)
C
               CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
     $                      LDA, TAU( I ), WORK, LDWORK )
C
C              Apply H' to A(i+ib:m,i:n) from the right
C
               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
C
C           Apply H' to columns i:n of current block
C
            CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
     $                   IINFO )
C
C           Set columns 1:i-1 of current block to zero
C
            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
C
      WORK( 1 ) = IWS
      RETURN
      END
*Deck DORGQR
      SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, LWORK, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), TAU( * ), WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  DORGQR generates an M-by-N real matrix Q with orthonormal columns,
C  which is defined as the first N columns of a product of K elementary
C  reflectors of order M
C
C        Q  =  H(1) H(2) . . . H(k)
C
C  as returned by DGEQRF.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q. M >= N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines the
C          matrix Q. N >= K >= 0.
C
C  A       (input/output) Real*8 array, dimension (LDA,N)
C          On entry, the i-th column must contain the vector which
C          defines the elementary reflector H(i), for i = 1,2,...,k, as
C          returned by DGEQRF in the first k columns of its array
C          argument A.
C          On exit, the M-by-N matrix Q.
C
C  LDA     (input) INTEGER
C          The first dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) Real*8 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DGEQRF.
C
C  WORK    (workspace/output) Real*8 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK. LWORK >= max(1,N).
C          For optimum performance LWORK >= N*NB, where NB is the
C          optimal blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument has an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB,
     $                   NBMIN, NX
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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
      ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      If(Info.ne.0) Call GLBErr('DORGQR',Info)
C
C     Quick return if possible
C
      IF( N.LE.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
C
C     Determine the block size.
C
      NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
      NBMIN = 2
      NX = 0
      IWS = N
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
C
C        Determine when to cross over from blocked to unblocked code.
C
         NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) )
         IF( NX.LT.K ) THEN
C
C           Determine if workspace is large enough for blocked code.
C
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
C
C              Not enough workspace to use optimal NB:  reduce NB and
C              determine the minimum value of NB.
C
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) )
            END IF
         END IF
      END IF
C
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
C
C        Use blocked code after the last block.
C        The first kk columns are handled by the block method.
C
         KI = ( ( K-NX-1 ) / NB )*NB
         KK = MIN( K, KI+NB )
C
C        Set A(1:kk,kk+1:n) to zero.
C
         DO 20 J = KK + 1, N
            DO 10 I = 1, KK
               A( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
      ELSE
         KK = 0
      END IF
C
C     Use unblocked code for the last or only block.
C
      IF( KK.LT.N )
     $   CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
     $                TAU( KK+1 ), WORK, IINFO )
C
      IF( KK.GT.0 ) THEN
C
C        Use blocked code
C
         DO 50 I = KI + 1, 1, -NB
            IB = MIN( NB, K-I+1 )
            IF( I+IB.LE.N ) THEN
C
C              Form the triangular factor of the block reflector
C              H = H(i) H(i+1) . . . H(i+ib-1)
C
               CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB,
     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
C
C              Apply H to A(i:m,i+ib:n) from the left
C
               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
C
C           Apply H to rows i:m of current block
C
            CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
     $                   IINFO )
C
C           Set rows 1:i-1 of current block to zero
C
            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
C
      WORK( 1 ) = IWS
      RETURN
      END
*Deck DORM2R
      SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DORM2R overwrites the general real m by n matrix C with
C
C        Q * C  if SIDE = 'L' and TRANS = 'N', or
C
C        Q'* C  if SIDE = 'L' and TRANS = 'T', or
C
C        C * Q  if SIDE = 'R' and TRANS = 'N', or
C
C        C * Q' if SIDE = 'R' and TRANS = 'T',
C
C  where Q is a real orthogonal matrix defined as the product of k
C  elementary reflectors
C
C        Q = H(1) H(2) . . . H(k)
C
C  as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n
C  if SIDE = 'R'.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': apply Q or Q' from the Left
C          = 'R': apply Q or Q' from the Right
C
C  TRANS   (input) CHARACTER*1
C          = 'N': apply Q  (No transpose)
C          = 'T': apply Q' (Transpose)
C
C  M       (input) INTEGER
C          The number of rows of the matrix C. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C. N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines
C          the matrix Q.
C          If SIDE = 'L', M >= K >= 0;
C          if SIDE = 'R', N >= K >= 0.
C
C  A       (input) Real*8 array, dimension (LDA,K)
C          The i-th column must contain the vector which defines the
C          elementary reflector H(i), for i = 1,2,...,k, as returned by
C          DGEQRF in the first k columns of its array argument A.
C          A is modified by the routine but restored on exit.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.
C          If SIDE = 'L', LDA >= max(1,M);
C          if SIDE = 'R', LDA >= max(1,N).
C
C  TAU     (input) Real*8 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DGEQRF.
C
C  C       (input/output) Real*8 array, dimension (LDC,N)
C          On entry, the m by n matrix C.
C          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace) Real*8 array, dimension
C                                   (N) if SIDE = 'L',
C                                   (M) if SIDE = 'R'
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
      Real*8   AII
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      LEFT = GLSame( SIDE, 'L' )
      NOTRAN = GLSame( TRANS, 'N' )
C
C     NQ is the order of Q
C
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.GLSame( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.GLSame( 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) Call GLBErr('DORM2R',Info)
      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
C
      IF( LEFT ) THEN
         NI = N
         JC = 1
      ELSE
         MI = M
         IC = 1
      END IF
C
      DO 10 I = I1, I2, I3
         IF( LEFT ) THEN
C
C           H(i) is applied to C(i:m,1:n)
C
            MI = M - I + 1
            IC = I
         ELSE
C
C           H(i) is applied to C(1:m,i:n)
C
            NI = N - I + 1
            JC = I
         END IF
C
C        Apply H(i)
C
         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
*Deck DORMBR
      SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
     $                   LDC, WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS, VECT
      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), C( LDC, * ), TAU( * ),
     $                   WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C
C  with
C                  SIDE = 'L'     SIDE = 'R'
C  TRANS = 'N':      Q * C          C * Q
C  TRANS = 'T':      Q**T * C       C * Q**T
C
C  If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C
C  with
C                  SIDE = 'L'     SIDE = 'R'
C  TRANS = 'N':      P * C          C * P
C  TRANS = 'T':      P**T * C       C * P**T
C
C  Here Q and P**T are the orthogonal matrices determined by DGEBRD when
C  reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
C  P**T are defined as products of elementary reflectors H(i) and G(i)
C  respectively.
C
C  Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
C  order of the orthogonal matrix Q or P**T that is applied.
C
C  If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
C  if nq >= k, Q = H(1) H(2) . . . H(k);
C  if nq < k, Q = H(1) H(2) . . . H(nq-1).
C
C  If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
C  if k < nq, P = G(1) G(2) . . . G(k);
C  if k >= nq, P = G(1) G(2) . . . G(nq-1).
C
C  Arguments
C  =========
C
C  VECT    (input) CHARACTER*1
C          = 'Q': apply Q or Q**T;
C          = 'P': apply P or P**T.
C
C  SIDE    (input) CHARACTER*1
C          = 'L': apply Q, Q**T, P or P**T from the Left;
C          = 'R': apply Q, Q**T, P or P**T from the Right.
C
C  TRANS   (input) CHARACTER*1
C          = 'N':  No transpose, apply Q  or P;
C          = 'T':  Transpose, apply Q**T or P**T.
C
C  M       (input) INTEGER
C          The number of rows of the matrix C. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C. N >= 0.
C
C  K       (input) INTEGER
C          If VECT = 'Q', the number of columns in the original
C          matrix reduced by DGEBRD.
C          If VECT = 'P', the number of rows in the original
C          matrix reduced by DGEBRD.
C          K >= 0.
C
C  A       (input) Real*8 array, dimension
C                                (LDA,min(nq,K)) if VECT = 'Q'
C                                (LDA,nq)        if VECT = 'P'
C          The vectors which define the elementary reflectors H(i) and
C          G(i), whose products determine the matrices Q and P, as
C          returned by DGEBRD.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.
C          If VECT = 'Q', LDA >= max(1,nq);
C          if VECT = 'P', LDA >= max(1,min(nq,K)).
C
C  TAU     (input) Real*8 array, dimension (min(nq,K))
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i) or G(i) which determines Q or P, as returned
C          by DGEBRD in the array argument TAUQ or TAUP.
C
C  C       (input/output) Real*8 array, dimension (LDC,N)
C          On entry, the M-by-N matrix C.
C          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q
C          or P*C or P**T*C or C*P or C*P**T.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace/output) Real*8 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK.
C          If SIDE = 'L', LWORK >= max(1,N);
C          if SIDE = 'R', LWORK >= max(1,M).
C          For optimum performance LWORK >= N*NB if SIDE = 'L', and
C          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
C          blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Local Scalars ..
      LOGICAL            APPLYQ, LEFT, NOTRAN
      CHARACTER          TRANST
      INTEGER            I1, I2, IINFO, MI, NI, NQ, NW
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      APPLYQ = GLSame( VECT, 'Q' )
      LEFT = GLSame( SIDE, 'L' )
      NOTRAN = GLSame( TRANS, 'N' )
C
C     NQ is the order of Q or P and NW is the minimum dimension of WORK
C
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.APPLYQ .AND. .NOT.GLSame( VECT, 'P' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LEFT .AND. .NOT.GLSame( SIDE, 'R' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOTRAN .AND. .NOT.GLSame( 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 ) ) THEN
         INFO = -13
      END IF
      If(Info.ne.0) Call GLBErr('DORMBR',Info)
      WORK( 1 ) = 1
      If(M.eq.0.or.N.eq.0) RETURN
      IF( APPLYQ ) THEN
C
C        Apply Q
C
         IF( NQ.GE.K ) THEN
C
C           Q was determined by a call to DGEBRD with nq >= k
C
            CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, LWORK, IINFO )
         ELSE IF( NQ.GT.1 ) THEN
C
C           Q was determined by a call to DGEBRD with nq < k
C
            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
C
C        Apply P
C
         IF( NOTRAN ) THEN
            TRANST = 'T'
         ELSE
            TRANST = 'N'
         END IF
         IF( NQ.GT.K ) THEN
C
C           P was determined by a call to DGEBRD with nq > k
C
            CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, LWORK, IINFO )
         ELSE IF( NQ.GT.1 ) THEN
C
C           P was determined by a call to DGEBRD with nq <= k
C
            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
      RETURN
      END
*Deck DORML2
      SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DORML2 overwrites the general real m by n matrix C with
C
C        Q * C  if SIDE = 'L' and TRANS = 'N', or
C
C        Q'* C  if SIDE = 'L' and TRANS = 'T', or
C
C        C * Q  if SIDE = 'R' and TRANS = 'N', or
C
C        C * Q' if SIDE = 'R' and TRANS = 'T',
C
C  where Q is a real orthogonal matrix defined as the product of k
C  elementary reflectors
C
C        Q = H(k) . . . H(2) H(1)
C
C  as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n
C  if SIDE = 'R'.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': apply Q or Q' from the Left
C          = 'R': apply Q or Q' from the Right
C
C  TRANS   (input) CHARACTER*1
C          = 'N': apply Q  (No transpose)
C          = 'T': apply Q' (Transpose)
C
C  M       (input) INTEGER
C          The number of rows of the matrix C. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C. N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines
C          the matrix Q.
C          If SIDE = 'L', M >= K >= 0;
C          if SIDE = 'R', N >= K >= 0.
C
C  A       (input) Real*8 array, dimension
C                               (LDA,M) if SIDE = 'L',
C                               (LDA,N) if SIDE = 'R'
C          The i-th row must contain the vector which defines the
C          elementary reflector H(i), for i = 1,2,...,k, as returned by
C          DGELQF in the first k rows of its array argument A.
C          A is modified by the routine but restored on exit.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A. LDA >= max(1,K).
C
C  TAU     (input) Real*8 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DGELQF.
C
C  C       (input/output) Real*8 array, dimension (LDC,N)
C          On entry, the m by n matrix C.
C          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace) Real*8 array, dimension
C                                   (N) if SIDE = 'L',
C                                   (M) if SIDE = 'R'
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
      Real*8   AII
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      LEFT = GLSame( SIDE, 'L' )
      NOTRAN = GLSame( TRANS, 'N' )
C
C     NQ is the order of Q
C
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.GLSame( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.GLSame( 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) Call GLBErr('DORML2',Info)
      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
C
      IF( LEFT ) THEN
         NI = N
         JC = 1
      ELSE
         MI = M
         IC = 1
      END IF
C
      DO 10 I = I1, I2, I3
         IF( LEFT ) THEN
C
C           H(i) is applied to C(i:m,1:n)
C
            MI = M - I + 1
            IC = I
         ELSE
C
C           H(i) is applied to C(1:m,i:n)
C
            NI = N - I + 1
            JC = I
         END IF
C
C        Apply H(i)
C
         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
*Deck DORMLQ
      SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), C( LDC, * ), TAU( * ),
     $                   WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  DORMLQ overwrites the general real M-by-N matrix C with
C
C                  SIDE = 'L'     SIDE = 'R'
C  TRANS = 'N':      Q * C          C * Q
C  TRANS = 'T':      Q**T * C       C * Q**T
C
C  where Q is a real orthogonal matrix defined as the product of k
C  elementary reflectors
C
C        Q = H(k) . . . H(2) H(1)
C
C  as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N
C  if SIDE = 'R'.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': apply Q or Q**T from the Left;
C          = 'R': apply Q or Q**T from the Right.
C
C  TRANS   (input) CHARACTER*1
C          = 'N':  No transpose, apply Q;
C          = 'T':  Transpose, apply Q**T.
C
C  M       (input) INTEGER
C          The number of rows of the matrix C. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C. N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines
C          the matrix Q.
C          If SIDE = 'L', M >= K >= 0;
C          if SIDE = 'R', N >= K >= 0.
C
C  A       (input) Real*8 array, dimension
C                               (LDA,M) if SIDE = 'L',
C                               (LDA,N) if SIDE = 'R'
C          The i-th row must contain the vector which defines the
C          elementary reflector H(i), for i = 1,2,...,k, as returned by
C          DGELQF in the first k rows of its array argument A.
C          A is modified by the routine but restored on exit.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A. LDA >= max(1,K).
C
C  TAU     (input) Real*8 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DGELQF.
C
C  C       (input/output) Real*8 array, dimension (LDC,N)
C          On entry, the M-by-N matrix C.
C          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace/output) Real*8 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK.
C          If SIDE = 'L', LWORK >= max(1,N);
C          if SIDE = 'R', LWORK >= max(1,M).
C          For optimum performance LWORK >= N*NB if SIDE = 'L', and
C          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
C          blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      INTEGER            NBMAX, LDT
      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
C     ..
C     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      CHARACTER          TRANST
      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
     $                   MI, NB, NBMIN, NI, NQ, NW
C     ..
C     .. Local Arrays ..
      Real*8   T( LDT, NBMAX )
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      LEFT = GLSame( SIDE, 'L' )
      NOTRAN = GLSame( TRANS, 'N' )
C
C     NQ is the order of Q and NW is the minimum dimension of WORK
C
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.LEFT .AND. .NOT.GLSame( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.GLSame( 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 ) ) THEN
         INFO = -12
      END IF
      If(Info.ne.0) Call GLBErr('DORMLQ',Info)
      WORK( 1 ) = 1
      If(M.eq.0.or.N.eq.0.or.K.eq.0) RETURN
C
C     Determine the block size.  NB may be at most NBMAX, where NBMAX
C     is used to define the local array T.
C
      NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K,
     $     -1 ) )
      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
C
      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
C
C        Use unblocked code
C
         CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
     $                IINFO )
      ELSE
C
C        Use blocked code
C
         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
C
         IF( LEFT ) THEN
            NI = N
            JC = 1
         ELSE
            MI = M
            IC = 1
         END IF
C
         IF( NOTRAN ) THEN
            TRANST = 'T'
         ELSE
            TRANST = 'N'
         END IF
C
         DO 10 I = I1, I2, I3
            IB = MIN( NB, K-I+1 )
C
C           Form the triangular factor of the block reflector
C           H = H(i) H(i+1) . . . H(i+ib-1)
C
            CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ),
     $                   LDA, TAU( I ), T, LDT )
            IF( LEFT ) THEN
C
C              H or H' is applied to C(i:m,1:n)
C
               MI = M - I + 1
               IC = I
            ELSE
C
C              H or H' is applied to C(1:m,i:n)
C
               NI = N - I + 1
               JC = I
            END IF
C
C           Apply H or H'
C
            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 ) = IWS
      RETURN
      END
*Deck DORMQR
      SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
C     ..
C     .. Array Arguments ..
      Real*8   A( LDA, * ), C( LDC, * ), TAU( * ),
     $                   WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  DORMQR overwrites the general real M-by-N matrix C with
C
C                  SIDE = 'L'     SIDE = 'R'
C  TRANS = 'N':      Q * C          C * Q
C  TRANS = 'T':      Q**T * C       C * Q**T
C
C  where Q is a real orthogonal matrix defined as the product of k
C  elementary reflectors
C
C        Q = H(1) H(2) . . . H(k)
C
C  as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N
C  if SIDE = 'R'.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': apply Q or Q**T from the Left;
C          = 'R': apply Q or Q**T from the Right.
C
C  TRANS   (input) CHARACTER*1
C          = 'N':  No transpose, apply Q;
C          = 'T':  Transpose, apply Q**T.
C
C  M       (input) INTEGER
C          The number of rows of the matrix C. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C. N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines
C          the matrix Q.
C          If SIDE = 'L', M >= K >= 0;
C          if SIDE = 'R', N >= K >= 0.
C
C  A       (input) Real*8 array, dimension (LDA,K)
C          The i-th column must contain the vector which defines the
C          elementary reflector H(i), for i = 1,2,...,k, as returned by
C          DGEQRF in the first k columns of its array argument A.
C          A is modified by the routine but restored on exit.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.
C          If SIDE = 'L', LDA >= max(1,M);
C          if SIDE = 'R', LDA >= max(1,N).
C
C  TAU     (input) Real*8 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DGEQRF.
C
C  C       (input/output) Real*8 array, dimension (LDC,N)
C          On entry, the M-by-N matrix C.
C          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace/output) Real*8 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK.
C          If SIDE = 'L', LWORK >= max(1,N);
C          if SIDE = 'R', LWORK >= max(1,M).
C          For optimum performance LWORK >= N*NB if SIDE = 'L', and
C          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
C          blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      INTEGER            NBMAX, LDT
      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
C     ..
C     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
     $                   MI, NB, NBMIN, NI, NQ, NW
C     ..
C     .. Local Arrays ..
      Real*8   T( LDT, NBMAX )
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      LEFT = GLSame( SIDE, 'L' )
      NOTRAN = GLSame( TRANS, 'N' )
C
C     NQ is the order of Q and NW is the minimum dimension of WORK
C
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.LEFT .AND. .NOT.GLSame( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.GLSame( 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 ) ) THEN
         INFO = -12
      END IF
      If(Info.ne.0) Call GLBErr('DORMQR',Info)
      WORK( 1 ) = 1
      If(M.eq.0.or.N.eq.0.or.K.eq.0) RETURN
C
C     Determine the block size.  NB may be at most NBMAX, where NBMAX
C     is used to define the local array T.
C
      NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K,
     $     -1 ) )
      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
C
      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
C
C        Use unblocked code
C
         CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
     $                IINFO )
      ELSE
C
C        Use blocked code
C
         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
C
         IF( LEFT ) THEN
            NI = N
            JC = 1
         ELSE
            MI = M
            IC = 1
         END IF
C
         DO 10 I = I1, I2, I3
            IB = MIN( NB, K-I+1 )
C
C           Form the triangular factor of the block reflector
C           H = H(i) H(i+1) . . . H(i+ib-1)
C
            CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
     $                   LDA, TAU( I ), T, LDT )
            IF( LEFT ) THEN
C
C              H or H' is applied to C(i:m,1:n)
C
               MI = M - I + 1
               IC = I
            ELSE
C
C              H or H' is applied to C(1:m,i:n)
C
               NI = N - I + 1
               JC = I
            END IF
C
C           Apply H or H'
C
            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 ) = IWS
      RETURN
      END
*Deck DPPSV
      SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK driver routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     March 31, 1993
C
C     .. Scalar Arguments ..
      CHARACTER*(*)      UPLO
      INTEGER            INFO, LDB, N, NRHS
C     ..
C     .. Array Arguments ..
      Real*8   AP( * ), B( LDB, * )
C     ..
C
C  Purpose
C  =======
C
C  DPPSV computes the solution to a real system of linear equations
C     A * X = B,
C  where A is an N-by-N symmetric positive definite matrix stored in
C  packed format and X and B are N-by-NRHS matrices.
C
C  The Cholesky decomposition is used to factor A as
C     A = U**T* U,  if UPLO = 'U', or
C     A = L * L**T,  if UPLO = 'L',
C  where U is an upper triangular matrix and L is a lower triangular
C  matrix.  The factored form of A is then used to solve the system of
C  equations A * X = B.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          = 'U':  Upper triangle of A is stored;
C          = 'L':  Lower triangle of A is stored.
C
C  N       (input) INTEGER
C          The number of linear equations, i.e., the order of the
C          matrix A.  N >= 0.
C
C  NRHS    (input) INTEGER
C          The number of right hand sides, i.e., the number of columns
C          of the matrix B.  NRHS >= 0.
C
C  AP      (input/output) Real*8 array, dimension (N*(N+1)/2)
C          On entry, the upper or lower triangle of the symmetric matrix
C          A, packed columnwise in a linear array.  The j-th column of A
C          is stored in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
C          See below for further details.
C
C          On exit, if INFO = 0, the factor U or L from the Cholesky
C          factorization A = U**T*U or A = L*L**T, in the same storage
C          format as A.
C
C  B       (input/output) Real*8 array, dimension (LDB,NRHS)
C          On entry, the N-by-NRHS right hand side matrix B.
C          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
C
C  LDB     (input) INTEGER
C          The leading dimension of the array B.  LDB >= max(1,N).
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C          > 0:  if INFO = i, the leading minor of order i of A is not
C                positive definite, so the factorization could not be
C                completed, and the solution has not been computed.
C
C  Further Details
C  ===============
C
C  The packed storage scheme is illustrated by the following example
C  when N = 4, UPLO = 'U':
C
C  Two-dimensional storage of the symmetric matrix A:
C
C     a11 a12 a13 a14
C         a22 a23 a24
C             a33 a34     (aij = conjg(aji))
C                 a44
C
C  Packed storage of the upper triangle of A:
C
C  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
C
C  =====================================================================
C
      LOGICAL            GLSame
C
C     Test the input parameters.
C
      INFO = 0
      IF( .NOT.GLSame( UPLO, 'U' ) .AND. .NOT.GLSame( 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 ) Call GauErr('Illegal argument to DPPSv.')
C
C     Compute the Cholesky factorization A = U'*U or A = L*L'.
C
      CALL DPPTRF( UPLO, N, AP, INFO )
      IF( INFO.EQ.0 ) THEN
C
C        Solve the system A*X = B, overwriting B with X.
C
         CALL DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
        END IF
      RETURN
      END
*Deck DPPTRF
      SUBROUTINE DPPTRF( UPLO, N, AP, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     March 31, 1993
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
C     ..
C     .. Array Arguments ..
      Real*8   AP( * )
C     ..
C
C  Purpose
C  =======
C
C  DPPTRF computes the Cholesky factorization of a real symmetric
C  positive definite matrix A stored in packed format.
C
C  The factorization has the form
C     A = U**T * U,  if UPLO = 'U', or
C     A = L  * L**T,  if UPLO = 'L',
C  where U is an upper triangular matrix and L is lower triangular.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          = 'U':  Upper triangle of A is stored;
C          = 'L':  Lower triangle of A is stored.
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  AP      (input/output) Real*8 array, dimension (N*(N+1)/2)
C          On entry, the upper or lower triangle of the symmetric matrix
C          A, packed columnwise in a linear array.  The j-th column of A
C          is stored in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
C          See below for further details.
C
C          On exit, if INFO = 0, the triangular factor U or L from the
C          Cholesky factorization A = U**T*U or A = L*L**T, in the same
C          storage format as A.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C          > 0:  if INFO = i, the leading minor of order i is not
C                positive definite, and the factorization could not be
C                completed.
C
C  Further Details
C  ======= =======
C
C  The packed storage scheme is illustrated by the following example
C  when N = 4, UPLO = 'U':
C
C  Two-dimensional storage of the symmetric matrix A:
C
C     a11 a12 a13 a14
C         a22 a23 a24
C             a33 a34     (aij = aji)
C                 a44
C
C  Packed storage of the upper triangle of A:
C
C  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER, GLSame
      INTEGER            J, JC, JJ
      Real*8   AJJ
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      UPPER = GLSame( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.GLSame( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      If(Info.ne.0) Call GLBErr('DPPTR',Info)
      If(N.eq.0) RETURN
      IF( UPPER ) THEN
C
C        Compute the Cholesky factorization A = U'*U.
C
         JJ = 0
         DO 10 J = 1, N
            JC = JJ + 1
            JJ = JJ + J
C
C           Compute elements 1:J-1 of column J.
C
            IF( J.GT.1 )
     $         CALL GTPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP,
     $                     AP( JC ), 1 )
C
C           Compute U(J,J) and test for non-positive-definiteness.
C
            AJJ = AP( JJ ) - SProd( J-1, AP( JC ), AP( JC ))
            IF( AJJ.LE.ZERO ) THEN
               AP( JJ ) = AJJ
               GO TO 30
            END IF
            AP( JJ ) = SQRT( AJJ )
   10    CONTINUE
      ELSE
C
C        Compute the Cholesky factorization A = L*L'.
C
         JJ = 1
         DO 20 J = 1, N
C
C           Compute L(J,J) and test for non-positive-definiteness.
C
            AJJ = AP( JJ )
            IF( AJJ.LE.ZERO ) THEN
               AP( JJ ) = AJJ
               GO TO 30
            END IF
            AJJ = SQRT( AJJ )
            AP( JJ ) = AJJ
C
C           Compute elements J+1:N of column J and update the trailing
C           submatrix.
C
            IF( J.LT.N ) THEN
               CALL AScale( N-J, ONE / AJJ, AP( JJ+1 ), AP( JJ+1 ))
               CALL GSPR( '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
C
   30 CONTINUE
      INFO = J
C
   40 CONTINUE
      RETURN
      END
*Deck DPPTRS
      SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     March 31, 1993
C
C     .. Scalar Arguments ..
      CHARACTER*(*)      UPLO
      INTEGER            INFO, LDB, N, NRHS
C     ..
C     .. Array Arguments ..
      Real*8   AP( * ), B( LDB, * )
C     ..
C
C  Purpose
C  =======
C
C  DPPTRS solves a system of linear equations A*X = B with a symmetric
C  positive definite matrix A in packed storage using the Cholesky
C  factorization A = U**T*U or A = L*L**T computed by DPPTRF.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          = 'U':  Upper triangle of A is stored;
C          = 'L':  Lower triangle of A is stored.
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  NRHS    (input) INTEGER
C          The number of right hand sides, i.e., the number of columns
C          of the matrix B.  NRHS >= 0.
C
C  AP      (input) Real*8 array, dimension (N*(N+1)/2)
C          The triangular factor U or L from the Cholesky factorization
C          A = U**T*U or A = L*L**T, packed columnwise in a linear
C          array.  The j-th column of U or L is stored in the array AP
C          as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
C
C  B       (input/output) Real*8 array, dimension (LDB,NRHS)
C          On entry, the right hand side matrix B.
C          On exit, the solution matrix X.
C
C  LDB     (input) INTEGER
C          The leading dimension of the array B.  LDB >= max(1,N).
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
      LOGICAL            UPPER
      INTEGER            I
      LOGICAL            GLSame
C
C     Test the input parameters.
C
      INFO = 0
      UPPER = GLSame( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.GLSame( 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 ) Call GauErr('Illegal argument to DPPTRS.')
C
C     Quick return if possible
C
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
C
      IF( UPPER ) THEN
C
C        Solve A*X = B where A = U'*U.
C
         DO 10 I = 1, NRHS
C
C           Solve U'*X = B, overwriting B with X.
C
            CALL GTPSv( 'Upper', 'Transpose', 'Non-unit', N, AP,
     $                  B( 1, I ), 1 )
C
C           Solve U*X = B, overwriting B with X.
C
            CALL GTPSv( 'Upper', 'No transpose', 'Non-unit', N, AP,
     $                  B( 1, I ), 1 )
   10    CONTINUE
      ELSE
C
C        Solve A*X = B where A = L*L'.
C
         DO 20 I = 1, NRHS
C
C           Solve L*Y = B, overwriting B with X.
C
            CALL GTPSv( 'Lower', 'No transpose', 'Non-unit', N, AP,
     $                  B( 1, I ), 1 )
C
C           Solve L'*X = Y, overwriting B with X.
C
            CALL GTPSv( 'Lower', 'Transpose', 'Non-unit', N, AP,
     $                  B( 1, I ), 1 )
   20    CONTINUE
      END IF
      RETURN
      END
*Deck DSPEV
      SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK driver routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     March 31, 1993
C
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, LDZ, N
      Real*8   AP( * ), W( * ), WORK( * ), Z( LDZ, * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  DSPEV computes all the eigenvalues and, optionally, eigenvectors of a
C  real symmetric matrix A in packed storage.
C
C  Arguments
C  =========
C
C  JOBZ    (input) CHARACTER*1
C          = 'N':  Compute eigenvalues only;
C          = 'V':  Compute eigenvalues and eigenvectors.
C
C  UPLO    (input) CHARACTER*1
C          = 'U':  Upper triangle of A is stored;
C          = 'L':  Lower triangle of A is stored.
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  AP      (input/output) Real*8 array, dimension (N*(N+1)/2)
C          On entry, the upper or lower triangle of the symmetric matrix
C          A, packed columnwise in a linear array.  The j-th column of A
C          is stored in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
C
C          On exit, AP is overwritten by values generated during the
C          reduction to tridiagonal form.  If UPLO = 'U', the diagonal
C          and first superdiagonal of the tridiagonal matrix T overwrite
C          the corresponding elements of A, and if UPLO = 'L', the
C          diagonal and first subdiagonal of T overwrite the
C          corresponding elements of A.
C
C  W       (output) Real*8 array, dimension (N)
C          If INFO = 0, the eigenvalues in ascending order.
C
C  Z       (output) Real*8 array, dimension (LDZ, N)
C          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
C          eigenvectors of the matrix A, with the i-th column of Z
C          holding the eigenvector associated with W(i).
C          If JOBZ = 'N', then Z is not referenced.
C
C  LDZ     (input) INTEGER
C          The leading dimension of the array Z.  LDZ >= 1, and if
C          JOBZ = 'V', LDZ >= max(1,N).
C
C  WORK    (workspace) Real*8 array, dimension (3*N)
C
C  INFO    (output) INTEGER
C          = 0:  successful exit.
C          < 0:  if INFO = -i, the i-th argument had an illegal value.
C          > 0:  if INFO = i, the algorithm failed to converge; i
C                off-diagonal elements of an intermediate tridiagonal
C                form did not converge to zero.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            WANTZ
      INTEGER            IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE
      Real*8   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
     $                   SMLNUM
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
#ifdef USE_ESSL_LAP
      Call GauErr('Use_ESSL_LAP set but generic DHPEV called.')
#endif
      WANTZ = GLSame( JOBZ, 'V' )
C
      INFO = 0
      IF( .NOT.( WANTZ .OR. GLSame( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( GLSame( UPLO, 'U' ) .OR. GLSame( 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) Call GLBErr('DSPEV',Info)
      If(N.eq.0) RETURN
      IF( N.EQ.1 ) THEN
         W( 1 ) = AP( 1 )
         IF( WANTZ )
     $      Z( 1, 1 ) = ONE
         RETURN
      END IF
C
C     Get machine constants.
C
      SAFMIN = SFMin
      EPSX = Prec
      SMLNUM = SAFMIN / EPSX
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = SQRT( BIGNUM )
C
C     Scale matrix to allowable range, if necessary.
C
      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 GScal( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
      END IF
C
C     Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
C
      INDE = 1
      INDTAU = INDE + N
      CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
C
C     For eigenvalues only, call DSTERF.  For eigenvectors, first call
C     DOPGTR to generate the orthogonal matrix, then call DSTEQR.
C
      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
C
C     If matrix was scaled, then rescale eigenvalues appropriately.
C
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = N
         ELSE
            IMAX = INFO - 1
         END IF
         CALL GScal( IMAX, ONE / SIGMA, W, 1 )
      END IF
      RETURN
      END
*Deck DSPTRD
      SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     March 31, 1993
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
C     ..
C     .. Array Arguments ..
      Real*8   AP( * ), D( * ), E( * ), TAU( * )
C     ..
C
C  Purpose
C  =======
C
C  DSPTRD reduces a real symmetric matrix A stored in packed form to
C  symmetric tridiagonal form T by an orthogonal similarity
C  transformation: Q**T * A * Q = T.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          = 'U':  Upper triangle of A is stored;
C          = 'L':  Lower triangle of A is stored.
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  AP      (input/output) Real*8 array, dimension (N*(N+1)/2)
C          On entry, the upper or lower triangle of the symmetric matrix
C          A, packed columnwise in a linear array.  The j-th column of A
C          is stored in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
C          On exit, if UPLO = 'U', the diagonal and first superdiagonal
C          of A are overwritten by the corresponding elements of the
C          tridiagonal matrix T, and the elements above the first
C          superdiagonal, with the array TAU, represent the orthogonal
C          matrix Q as a product of elementary reflectors; if UPLO
C          = 'L', the diagonal and first subdiagonal of A are over-
C          written by the corresponding elements of the tridiagonal
C          matrix T, and the elements below the first subdiagonal, with
C          the array TAU, represent the orthogonal matrix Q as a product
C          of elementary reflectors. See Further Details.
C
C  D       (output) Real*8 array, dimension (N)
C          The diagonal elements of the tridiagonal matrix T:
C          D(i) = A(i,i).
C
C  E       (output) Real*8 array, dimension (N-1)
C          The off-diagonal elements of the tridiagonal matrix T:
C          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
C
C  TAU     (output) Real*8 array, dimension (N-1)
C          The scalar factors of the elementary reflectors (see Further
C          Details).
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  Further Details
C  ===============
C
C  If UPLO = 'U', the matrix Q is represented as a product of elementary
C  reflectors
C
C     Q = H(n-1) . . . H(2) H(1).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a real scalar, and v is a real vector with
C  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
C  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
C
C  If UPLO = 'L', the matrix Q is represented as a product of elementary
C  reflectors
C
C     Q = H(1) H(2) . . . H(n-1).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a real scalar, and v is a real vector with
C  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
C  overwriting A(i+2:n,i), and tau is stored in TAU(i).
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO, HALF
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0,
     $                   HALF = 1.0D0 / 2.0D0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, I1, I1I1, II
      Real*8   ALPHA, TAUI
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters
C
      INFO = 0
      UPPER = GLSame( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.GLSame( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      If(Info.ne.0) Call GLBErr('DSPTRD',Info)
      If(N.le.0) RETURN
      IF( UPPER ) THEN
C
C        Reduce the upper triangle of A.
C        I1 is the index in AP of A(1,I+1).
C
         I1 = N*( N-1 ) / 2 + 1
         DO 10 I = N - 1, 1, -1
C
C           Generate elementary reflector H(i) = I - tau * v * v'
C           to annihilate A(1:i-1,i+1)
C
            CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI )
            E( I ) = AP( I1+I-1 )
C
            IF( TAUI.NE.ZERO ) THEN
C
C              Apply H(i) from both sides to A(1:i,1:i)
C
               AP( I1+I-1 ) = ONE
C
C              Compute  y := tau * A * v  storing y in TAU(1:i)
C
               CALL GSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,1 )
C
C              Compute  w := y - 1/2 * tau * (y'*v) * v
C
               ALPHA = -HALF*TAUI*SProd( I, TAU, AP( I1 ))
               CALL ACASB( I, TAU, AP( I1 ), TAU, ALPHA)
C
C              Apply the transformation as a rank-2 update:
C                 A := A - v * w' - w * v'
C
               CALL GSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
C
               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
C
C        Reduce the lower triangle of A. II is the index in AP of
C        A(i,i) and I1I1 is the index of A(i+1,i+1).
C
         II = 1
         DO 20 I = 1, N - 1
            I1I1 = II + N - I + 1
C
C           Generate elementary reflector H(i) = I - tau * v * v'
C           to annihilate A(i+2:n,i)
C
            CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI )
            E( I ) = AP( II+1 )
C
            IF( TAUI.NE.ZERO ) THEN
C
C              Apply H(i) from both sides to A(i+1:n,i+1:n)
C
               AP( II+1 ) = ONE
C
C              Compute  y := tau * A * v  storing y in TAU(i:n-1)
C
               CALL GSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
     $                     ZERO, TAU( I ), 1 )
C
C              Compute  w := y - 1/2 * tau * (y'*v) * v
C
               ALPHA = -HALF*TAUI*SProd( N-I, TAU( I ), AP( II+1 ))
               CALL ACASB( N-I, Tau(I), AP( II+1 ), TAU( I ), Alpha)
C
C              Apply the transformation as a rank-2 update:
C                 A := A - v * w' - w * v'
C
               CALL GSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
     $                     AP( I1I1 ) )
C
               AP( II+1 ) = E( I )
            END IF
            D( I ) = AP( II )
            TAU( I ) = TAUI
            II = I1I1
   20    CONTINUE
         D( N ) = AP( II )
      END IF
C
      RETURN
      END
*Deck DSTEQR
      SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
      CHARACTER          COMPZ
      INTEGER            INFO, LDZ, N
      Real*8   D( * ), E( * ), WORK( * ), Z( LDZ, * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
C  symmetric tridiagonal matrix using the implicit QL or QR method.
C  The eigenvectors of a full or band symmetric matrix can also be found
C  if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
C  tridiagonal form.
C
C  Arguments
C  =========
C
C  COMPZ   (input) CHARACTER*1
C          = 'N':  Compute eigenvalues only.
C          = 'V':  Compute eigenvalues and eigenvectors of the original
C                  symmetric matrix.  On entry, Z must contain the
C                  orthogonal matrix used to reduce the original matrix
C                  to tridiagonal form.
C          = 'I':  Compute eigenvalues and eigenvectors of the
C                  tridiagonal matrix.  Z is initialized to the identity
C                  matrix.
C
C  N       (input) INTEGER
C          The order of the matrix.  N >= 0.
C
C  D       (input/output) Real*8 array, dimension (N)
C          On entry, the diagonal elements of the tridiagonal matrix.
C          On exit, if INFO = 0, the eigenvalues in ascending order.
C
C  E       (input/output) Real*8 array, dimension (N-1)
C          On entry, the (n-1) subdiagonal elements of the tridiagonal
C          matrix.
C          On exit, E has been destroyed.
C
C  Z       (input/output) Real*8 array, dimension (LDZ, N)
C          On entry, if  COMPZ = 'V', then Z contains the orthogonal
C          matrix used in the reduction to tridiagonal form.
C          On exit, if INFO = 0, then if  COMPZ = 'V', Z contains the
C          orthonormal eigenvectors of the original symmetric matrix,
C          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
C          of the symmetric tridiagonal matrix.
C          If COMPZ = 'N', then Z is not referenced.
C
C  LDZ     (input) INTEGER
C          The leading dimension of the array Z.  LDZ >= 1, and if
C          eigenvectors are desired, then  LDZ >= max(1,N).
C
C  WORK    (workspace) Real*8 array, dimension (max(1,2*N-2))
C          If COMPZ = 'N', then WORK is not referenced.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C          > 0:  the algorithm has failed to find all the eigenvalues in
C                a total of 30*N iterations; if INFO = i, then i
C                elements of E have not converged to zero; on exit, D
C                and E contain the elements of a symmetric tridiagonal
C                matrix which is orthogonally similar to the original
C                matrix.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO, ONE, TWO, THREE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                   THREE = 3.0D0 )
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
     $                   LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
     $                   NM1, NMAXIT
      Real*8   ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
     $                   S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
      LOGICAL            GLSame
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
C
      IF( GLSame( COMPZ, 'N' ) ) THEN
         ICOMPZ = 0
      ELSE IF( GLSame( COMPZ, 'V' ) ) THEN
         ICOMPZ = 1
      ELSE IF( GLSame( 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) Call GLBErr('DSTEQR',Info)
      If(N.eq.0) RETURN
      IF( N.EQ.1 ) THEN
         IF( ICOMPZ.EQ.2 )
     $      Z( 1, 1 ) = ONE
         RETURN
      END IF
C
C     Determine the unit roundoff and over/underflow thresholds.
C
      EPS2 = EPS**2
      SAFMIN = SFMin
      SAFMAX = ONE / SAFMIN
      SSFMAX = SQRT( SAFMAX ) / THREE
      SSFMIN = SQRT( SAFMIN ) / EPS2
C
C     Compute the eigenvalues and eigenvectors of the tridiagonal
C     matrix.
C
      IF( ICOMPZ.EQ.2 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
C
      NMAXIT = N*MAXIT
      JTOT = 0
C
C     Determine where the matrix splits and choose QL or QR iteration
C     for each block, according to whether top or bottom diagonal
C     element is smaller.
C
      L1 = 1
      NM1 = N - 1
C
   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
C
   30 CONTINUE
      L = L1
      LSV = L
      LEND = M
      LENDSV = LEND
      L1 = M + 1
      IF( LEND.EQ.L )
     $   GO TO 10
C
C     Scale submatrix in rows and columns L to LEND
C
      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
C
C     Choose between QL and QR iteration
C
      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
         LEND = LSV
         L = LENDSV
      END IF
C
      IF( LEND.GT.L ) THEN
C
C        QL Iteration
C
C        Look for small subdiagonal element.
C
   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
C
         M = LEND
C
   60    CONTINUE
         IF( M.LT.LEND )
     $      E( M ) = ZERO
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 80
C
C        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
C        to compute its eigensystem.
C
         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
C
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 140
         JTOT = JTOT + 1
C
C        Form shift.
C
         G = ( D( L+1 )-P ) / ( TWO*E( L ) )
         R = DLAPY2( G, ONE )
         G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
C
         S = ONE
         C = ONE
         P = ZERO
C
C        Inner loop
C
         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
C
C           If eigenvectors are desired, then save rotations.
C
            IF( ICOMPZ.GT.0 ) THEN
               WORK( I ) = C
               WORK( N-1+I ) = -S
            END IF
C
   70    CONTINUE
C
C        If eigenvectors are desired, then apply saved rotations.
C
         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
C
         D( L ) = D( L ) - P
         E( L ) = G
         GO TO 40
C
C        Eigenvalue found.
C
   80    CONTINUE
         D( L ) = P
C
         L = L + 1
         IF( L.LE.LEND )
     $      GO TO 40
         GO TO 140
C
      ELSE
C
C        QR Iteration
C
C        Look for small superdiagonal element.
C
   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
C
         M = LEND
C
  110    CONTINUE
         IF( M.GT.LEND )
     $      E( M-1 ) = ZERO
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 130
C
C        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
C        to compute its eigensystem.
C
         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
C
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 140
         JTOT = JTOT + 1
C
C        Form shift.
C
         G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
         R = DLAPY2( G, ONE )
         G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
C
         S = ONE
         C = ONE
         P = ZERO
C
C        Inner loop
C
         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
C
C           If eigenvectors are desired, then save rotations.
C
            IF( ICOMPZ.GT.0 ) THEN
               WORK( I ) = C
               WORK( N-1+I ) = S
            END IF
C
  120    CONTINUE
C
C        If eigenvectors are desired, then apply saved rotations.
C
         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
C
         D( L ) = D( L ) - P
         E( LM1 ) = G
         GO TO 90
C
C        Eigenvalue found.
C
  130    CONTINUE
         D( L ) = P
C
         L = L - 1
         IF( L.GE.LEND )
     $      GO TO 90
         GO TO 140
C
      END IF
C
C     Undo scaling if necessary
C
  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
C
C     Check for no convergence to an eigenvalue after a total
C     of N*MAXIT iterations.
C
      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
C
C     Order eigenvalues and eigenvectors.
C
  160 CONTINUE
      IF( ICOMPZ.EQ.0 ) THEN
C
C        Use Quick Sort
C
         CALL DLASRT( 'I', N, D, INFO )
C
      ELSE
C
C        Use Selection Sort to minimize swaps of eigenvectors
C
         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 GSwap( N, Z( 1, I ), 1, Z( 1, K ), 1 )
            END IF
  180    CONTINUE
      END IF
C
  190 CONTINUE
      RETURN
      END
*Deck DSTERF
      SUBROUTINE DSTERF( N, D, E, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
      INTEGER            INFO, N
      Real*8   D( * ), E( * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
C  using the Pal-Walker-Kahan variant of the QL or QR algorithm.
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The order of the matrix.  N >= 0.
C
C  D       (input/output) Real*8 array, dimension (N)
C          On entry, the n diagonal elements of the tridiagonal matrix.
C          On exit, if INFO = 0, the eigenvalues in ascending order.
C
C  E       (input/output) Real*8 array, dimension (N-1)
C          On entry, the (n-1) subdiagonal elements of the tridiagonal
C          matrix.
C          On exit, E has been destroyed.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C          > 0:  the algorithm failed to find all of the eigenvalues in
C                a total of 30*N iterations; if INFO = i, then i
C                elements of E have not converged to zero.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO, ONE, TWO, THREE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                   THREE = 3.0D0 )
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, ISCALE, JTOT, L, L1, LEND, LENDM1, LENDP1,
     $                   LENDSV, LM1, LSV, M, MM1, NM1, NMAXIT
      Real*8   ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
     $                   OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
     $                   SIGMA, SSFMAX, SSFMIN, TST
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
C
C     Quick return if possible
C
      IF( N.LT.0 ) THEN
        INFO = -1
        Call GauErr('Illegal argument to DSTERF.')
        RETURN
        END IF
      If(N.le.1) RETURN
C
C     Determine the unit roundoff for this environment.
C
      EPS2 = EPS**2
      SAFMIN = SFMin
      SAFMAX = ONE / SAFMIN
      SSFMAX = SQRT( SAFMAX ) / THREE
      SSFMIN = SQRT( SAFMIN ) / EPS2
C
C     Compute the eigenvalues of the tridiagonal matrix.
C
      NMAXIT = N*MAXIT
      SIGMA = ZERO
      JTOT = 0
C
C     Determine where the matrix splits and choose QL or QR iteration
C     for each block, according to whether top or bottom diagonal
C     element is smaller.
C
      L1 = 1
      NM1 = N - 1
C
   10 CONTINUE
      IF( L1.GT.N )
     $   GO TO 170
      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
C
   30 CONTINUE
      L = L1
      LSV = L
      LEND = M
      LENDSV = LEND
      L1 = M + 1
      IF( LEND.EQ.L )
     $   GO TO 10
C
C     Scale submatrix in rows and columns L to LEND
C
      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
C
      DO 40 I = L, LEND - 1
         E( I ) = E( I )**2
   40 CONTINUE
C
C     Choose between QL and QR iteration
C
      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
         LEND = LSV
         L = LENDSV
      END IF
C
      IF( LEND.GE.L ) THEN
C
C        QL Iteration
C
C        Look for small subdiagonal element.
C
   50    CONTINUE
         IF( L.NE.LEND ) THEN
            LENDM1 = LEND - 1
            DO 60 M = L, LENDM1
               TST = ABS( E( M ) )
               IF( TST.LE.EPS2*ABS( D( M )*D( M+1 ) ) )
     $            GO TO 70
   60       CONTINUE
         END IF
C
         M = LEND
C
   70    CONTINUE
         IF( M.LT.LEND )
     $      E( M ) = ZERO
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 90
C
C        If remaining matrix is 2 by 2, use DLAE2 to compute its
C        eigenvalues.
C
         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
C
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 150
         JTOT = JTOT + 1
C
C        Form shift.
C
         RTE = SQRT( E( L ) )
         SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
         R = DLAPY2( SIGMA, ONE )
         SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
C
         C = ONE
         S = ZERO
         GAMMA = D( M ) - SIGMA
         P = GAMMA*GAMMA
C
C        Inner loop
C
         MM1 = M - 1
         DO 80 I = MM1, 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
C
         E( L ) = S*P
         D( L ) = SIGMA + GAMMA
         GO TO 50
C
C        Eigenvalue found.
C
   90    CONTINUE
         D( L ) = P
C
         L = L + 1
         IF( L.LE.LEND )
     $      GO TO 50
         GO TO 150
C
      ELSE
C
C        QR Iteration
C
C        Look for small superdiagonal element.
C
  100    CONTINUE
         IF( L.NE.LEND ) THEN
            LENDP1 = LEND + 1
            DO 110 M = L, LENDP1, -1
               TST = ABS( E( M-1 ) )
               IF( TST.LE.EPS2*ABS( D( M )*D( M-1 ) ) )
     $            GO TO 120
  110       CONTINUE
         END IF
C
         M = LEND
C
  120    CONTINUE
         IF( M.GT.LEND )
     $      E( M-1 ) = ZERO
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 140
C
C        If remaining matrix is 2 by 2, use DLAE2 to compute its
C        eigenvalues.
C
         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
C
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 150
         JTOT = JTOT + 1
C
C        Form shift.
C
         RTE = SQRT( E( L-1 ) )
         SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
         R = DLAPY2( SIGMA, ONE )
         SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
C
         C = ONE
         S = ZERO
         GAMMA = D( M ) - SIGMA
         P = GAMMA*GAMMA
C
C        Inner loop
C
         LM1 = L - 1
         DO 130 I = M, LM1
            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
C
         E( LM1 ) = S*P
         D( L ) = SIGMA + GAMMA
         GO TO 100
C
C        Eigenvalue found.
C
  140    CONTINUE
         D( L ) = P
C
         L = L - 1
         IF( L.GE.LEND )
     $      GO TO 100
         GO TO 150
C
      END IF
C
C     Undo scaling if necessary
C
  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 )
C
C     Check for no convergence to an eigenvalue after a total
C     of N*MAXIT iterations.
C
      IF( JTOT.EQ.NMAXIT ) THEN
         DO 160 I = 1, N - 1
            IF( E( I ).NE.ZERO )
     $         INFO = INFO + 1
  160    CONTINUE
         RETURN
      END IF
      GO TO 10
C
C     Sort eigenvalues in increasing order.
C
  170 CONTINUE
      CALL DLASRT( 'I', N, D, INFO )
C
      RETURN
      END
*Deck DTPTRI
      SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, N
C     ..
C     .. Array Arguments ..
      Real*8   AP( * )
C     ..
C
C  Purpose
C  =======
C
C  DTPTRI computes the inverse of a real upper or lower triangular
C  matrix A stored in packed format.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          = 'U':  A is upper triangular;
C          = 'L':  A is lower triangular.
C
C  DIAG    (input) CHARACTER*1
C          = 'N':  A is non-unit triangular;
C          = 'U':  A is unit triangular.
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  AP      (input/output) Real*8 array, dimension (N*(N+1)/2)
C          On entry, the upper or lower triangular matrix A, stored
C          columnwise in a linear array.  The j-th column of A is stored
C          in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
C          See below for further details.
C          On exit, the (triangular) inverse of the original matrix, in
C          the same packed storage format.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C          > 0:  if INFO = i, A(i,i) is exactly zero.  The triangular
C                matrix is singular and its inverse can not be computed.
C
C  Further Details
C  ===============
C
C  A triangular matrix A can be transferred to packed storage using one
C  of the following program segments:
C
C  UPLO = 'U':                      UPLO = 'L':
C
C        JC = 1                           JC = 1
C        DO 2 J = 1, N                    DO 2 J = 1, N
C           DO 1 I = 1, J                    DO 1 I = J, N
C              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)
C      1    CONTINUE                    1    CONTINUE
C           JC = JC + J                      JC = JC + N - J + 1
C      2 CONTINUE                       2 CONTINUE
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER, GLSame
      INTEGER            J, JC, JCLAST, JJ
      Real*8   AJJ
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      JCLast = 0
      UPPER = GLSame( UPLO, 'U' )
      NOUNIT = GLSame( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.GLSame( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.GLSame( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      END IF
      If(Info.ne.0) Call GLBErr('DTPTRI',Info)
C
C     Check for singularity if non-unit.
C
      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
C
      IF( UPPER ) THEN
C
C        Compute inverse of upper triangular matrix.
C
         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
C
C           Compute elements 1:j-1 of j-th column.
C
            CALL GTPMV( 'Upper', 'No transpose', DIAG, J-1, AP,
     $                  AP( JC ), 1 )
            CALL AScale( J-1, AJJ, AP( JC ), AP(JC))
            JC = JC + J
   30    CONTINUE
C
      ELSE
C
C        Compute inverse of lower triangular matrix.
C
         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
C
C              Compute elements j+1:n of j-th column.
C
               CALL GTPMV( 'Lower', 'No transpose', DIAG, N-J,
     $                     AP( JCLAST ), AP( JC+1 ), 1 )
               CALL AScale( N-J, AJJ, AP( JC+1 ), AP(JC+1) )
            END IF
            JCLAST = JC
            JC = JC - N + J - 2
   40    CONTINUE
      END IF
C
      RETURN
      END
*Deck GLaMch
      Function GLaMch(CMach)
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
      Character*(*) CMach
C     ..
C
C  Purpose
C  =======
C
C  GLaMch determines Real*8 machine parameters.
C
C  Arguments
C  =========
C
C  CMACH   (input) CHARACTER*1
C          Specifies the value to be returned by GLaMch:
C          = 'E' or 'e',   GLaMch := eps
C          = 'S' or 's ,   GLaMch := sfmin
C          = 'B' or 'b',   GLaMch := base
C          = 'P' or 'p',   GLaMch := eps*base
C          = 'N' or 'n',   GLaMch := t
C          = 'R' or 'r',   GLaMch := rnd
C          = 'M' or 'm',   GLaMch := emin
C          = 'U' or 'u',   GLaMch := rmin
C          = 'L' or 'l',   GLaMch := emax
C          = 'O' or 'o',   GLaMch := rmax
C
C          where
C
C          eps   = relative machine precision
C          sfmin = safe minimum, such that 1/sfmin does not overflow
C          base  = base of the machine
C          prec  = eps*base
C          t     = number of (base) digits in the mantissa
C          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
C          emin  = minimum exponent before (gradual) underflow
C          rmin  = underflow threshold - base**(emin-1)
C          emax  = largest exponent before overflow
C          rmax  = overflow threshold  - (base**emax)*(1-eps)
C
C =====================================================================
C
      Real*8 One, Zero
      Parameter (One=1.0d+0,Zero=0.0d+0)
      Logical First, LRnd
      Integer Beta, IMax, IMin, IT
      Real*8 Base, EMax, EMin, Eps, Prec, RMach, RMax, RMin, Rnd, SFMin,
     $  Small, T
      Logical GLSame
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
      Save First
      Data First /.True./
C
C$OMP MASTER
      If(First) then
        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 )
          endIf
        PRec = Eps*Base
        EMin = IMin
        EMax = IMax
        SFMin = RMin
        Small = One / RMax
C
C       Use SMALL plus a bit, to avoid the possibility of rounding
C       causing overflow when computing  1/sfMin.
C
        If(Small.ge.SFMin) SFMin = Small*(One+Eps)
        First = .False.
        endIf
C$OMP END MASTER
      GLaMch = Zero
      If(First) Return
      If(GLSame(CMach,'E')) then
        RMach = Eps
      else if(GLSame(CMach,'S')) then
        RMach = SFMin
      else if(GLSame(CMach,'B')) then
        RMach = Base
      else if(GLSame(CMach,'P')) then
        RMach = Prec
      else if(GLSame(CMach,'N')) then
        RMach = T
      else if(GLSame(CMach,'R')) then
        RMach = Rnd
      else if(GLSame(CMach,'M')) then
        RMach = EMin
      else if(GLSame(CMach,'U')) then
        RMach = RMin
      else if(GLSame(CMach,'L' ) ) then
        RMach = EMax
      else if(GLSame(CMach, 'O' ) ) then
        RMach = RMax
      else
        RMach = Zero
        Call GauErr('Unrecognized argument to GLaMch.')
        endIf
      GLaMch = RMach
      Return
      End
*Deck ILAENV
      Integer Function ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,N4 )
      Implicit Integer(A-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
C     ..
C
C  Purpose
C  =======
C
C  ILAENV is called from the LAPACK routines to choose problem-dependent
C  parameters for the local environment.  See ISPEC for a description of
C  the parameters.
C
C  This version provides a set of parameters which should give good,
C  but not optimal, performance on many of the currently available
C  computers.  Users are encouraged to modify this subroutine to set
C  the tuning parameters for their particular machine using the option
C  and problem size information in the arguments.
C
C  This routine will not function correctly if it is converted to all
C  lower case.  Converting it to all upper case is allowed.
C
C  Arguments
C  =========
C
C  ISPEC   (input) INTEGER
C          Specifies the parameter to be returned as the value of
C          ILAENV.
C          = 1: the optimal blocksize; if this value is 1, an unblocked
C               algorithm will give the best performance.
C          = 2: the minimum block size for which the block routine
C               should be used; if the usable block size is less than
C               this value, an unblocked routine should be used.
C          = 3: the crossover point (in a block routine, for N less
C               than this value, an unblocked routine should be used)
C          = 4: the number of shifts, used in the nonsymmetric
C               eigenvalue routines
C          = 5: the minimum column dimension for blocking to be used;
C               rectangular blocks must have dimension at least k by m,
C               where k is given by ILAENV(2,...) and m by ILAENV(5,...)
C          = 6: the crossover point for the SVD (when reducing an m by n
C               matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
C               this value, a QR factorization is used first to reduce
C               the matrix to a triangular form.)
C          = 7: the number of processors
C          = 8: the crossover point for the multishift QR and QZ methods
C               for nonsymmetric eigenvalue problems.
C
C  NAME    (input) CHARACTER*(*)
C          The name of the calling subroutine, in either upper case or
C          lower case.
C
C  OPTS    (input) CHARACTER*(*)
C          The character options to the subroutine NAME, concatenated
C          into a single character string.  For example, UPLO = 'U',
C          TRANS = 'T', and DIAG = 'N' for a triangular routine would
C          be specified as OPTS = 'UTN'.
C
C  N1      (input) INTEGER
C  N2      (input) INTEGER
C  N3      (input) INTEGER
C  N4      (input) INTEGER
C          Problem dimensions for the subroutine NAME; these may not all
C          be required.
C
C (ILAENV) (output) INTEGER
C          >= 0: the value of the parameter specified by ISPEC
C          < 0:  if ILAENV = -k, the k-th argument had an illegal value.
C
C  Further Details
C  ===============
C
C  The following conventions have been used when calling ILAENV from the
C  LAPACK routines:
C  1)  OPTS is a concatenation of all of the character options to
C      subroutine NAME, in the same order that they appear in the
C      argument list for NAME, even if they are not used in determining
C      the value of the parameter specified by ISPEC.
C  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
C      that they appear in the argument list for NAME.  N1 is used
C      first, N2 second, and so on, and unused problem dimensions are
C      passed a value of -1.
C  3)  The parameter value returned by ILAENV is checked for validity in
C      the calling subroutine.  For example, ILAENV is used to retrieve
C      the optimal blocksize for STRTRI as follows:
C
C      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
C      IF( NB.LE.1 ) NB = MAX( 1, N )
C
C  =====================================================================
C
C     .. 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
C     ..
C     ..
C     .. Executable Statements ..
C
      GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC
C
C     Invalid value for ISPEC
C
      ILAENV = -1
      RETURN
C
  100 CONTINUE
C
C     Convert NAME to upper case if the first character is lower case.
C
      ILAENV = 1
      SUBNAM = NAME
      IC = ICHAR( SUBNAM( 1:1 ) )
      IZ = ICHAR( 'Z' )
      IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
C
C        ASCII character set
C
         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
C
      ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
C
C        EBCDIC character set
C
         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
C
      ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
C
C        Prime machines:  ASCII+128
C
         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
C
      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 )
C
      GO TO ( 110, 200, 300 ) ISPEC
C
  110 CONTINUE
C
C     ISPEC = 1:  block size
C
C     In these examples, separate code is provided for setting NB for
C     real and complex.  We assume that NB will take the same value in
C     single or Real*8.
C
      NB = 1
C
      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 = 1
         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 = 1
         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
C
  200 CONTINUE
C
C     ISPEC = 2:  minimum block size
C
      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
C
  300 CONTINUE
C
C     ISPEC = 3:  crossover point
C
      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 = 1
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NX = 1
         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
C
  400 CONTINUE
C
C     ISPEC = 4:  number of shifts (used by xHSEQR)
C
      ILAENV = 6
      RETURN
C
  500 CONTINUE
C
C     ISPEC = 5:  minimum column dimension (not used)
C
      ILAENV = 2
      RETURN
C
  600 CONTINUE
C
C     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD)
C
      ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
      RETURN
C
  700 CONTINUE
C
C     ISPEC = 7:  number of processors (not used)
C
      ILAENV = 1
      RETURN
C
  800 CONTINUE
C
C     ISPEC = 8:  crossover point for multishift (used by xHSEQR)
C
      ILAENV = 50
      RETURN
      END
*Deck ZBDSQR
      SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
     $  LDU, C, LDC, RWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
      CHARACTER          UPLO
      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
      Real*8   D( * ), E( * ), RWORK( * )
      COMPLEX*16         C( LDC, * ), U( LDU, * ), VT( LDVT, * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  ZBDSQR computes the singular value decomposition (SVD) of a real
C  N-by-N (upper or lower) bidiagonal matrix B:  B = Q * S * P' (P'
C  denotes the transpose of P), where S is a diagonal matrix with
C  non-negative diagonal elements (the singular values of B), and Q
C  and P are orthogonal matrices.
C
C  The routine computes S, and optionally computes U * Q, P' * VT,
C  or Q' * C, for given complex input matrices U, VT, and C.
C
C  See "Computing  Small Singular Values of Bidiagonal Matrices With
C  Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
C  LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
C  no. 5, pp. 873-912, Sept 1990) and
C  "Accurate singular values and differential qd algorithms," by
C  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
C  Department, University of California at Berkeley, July 1992
C  for a detailed description of the algorithm.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          = 'U':  B is upper bidiagonal;
C          = 'L':  B is lower bidiagonal.
C
C  N       (input) INTEGER
C          The order of the matrix B.  N >= 0.
C
C  NCVT    (input) INTEGER
C          The number of columns of the matrix VT. NCVT >= 0.
C
C  NRU     (input) INTEGER
C          The number of rows of the matrix U. NRU >= 0.
C
C  NCC     (input) INTEGER
C          The number of columns of the matrix C. NCC >= 0.
C
C  D       (input/output) Real*8 array, dimension (N)
C          On entry, the n diagonal elements of the bidiagonal matrix B.
C          On exit, if INFO=0, the singular values of B in decreasing
C          order.
C
C  E       (input/output) Real*8 array, dimension (N)
C          On entry, the elements of E contain the
C          offdiagonal elements of of the bidiagonal matrix whose SVD
C          is desired. On normal exit (INFO = 0), E is destroyed.
C          If the algorithm does not converge (INFO > 0), D and E
C          will contain the diagonal and superdiagonal elements of a
C          bidiagonal matrix orthogonally equivalent to the one given
C          as input. E(N) is used for workspace.
C
C  VT      (input/output) COMPLEX*16 array, dimension (LDVT, NCVT)
C          On entry, an N-by-NCVT matrix VT.
C          On exit, VT is overwritten by P' * VT.
C          VT is not referenced if NCVT = 0.
C
C  LDVT    (input) INTEGER
C          The leading dimension of the array VT.
C          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
C
C  U       (input/output) COMPLEX*16 array, dimension (LDU, N)
C          On entry, an NRU-by-N matrix U.
C          On exit, U is overwritten by U * Q.
C          U is not referenced if NRU = 0.
C
C  LDU     (input) INTEGER
C          The leading dimension of the array U.  LDU >= max(1,NRU).
C
C  C       (input/output) COMPLEX*16 array, dimension (LDC, NCC)
C          On entry, an N-by-NCC matrix C.
C          On exit, C is overwritten by Q' * C.
C          C is not referenced if NCC = 0.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C.
C          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
C
C  RWORK   (workspace) Real*8 array, dimension
C            2*N  if only singular values wanted (NCVT = NRU = NCC = 0)
C            max( 1, 4*N-4 ) otherwise
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  If INFO = -i, the i-th argument had an illegal value
C          > 0:  the algorithm did not converge; D and E contain the
C                elements of a bidiagonal matrix which is orthogonally
C                similar to the input matrix B;  if INFO = i, i
C                elements of E have not converged to zero.
C
C  Internal Parameters
C  ===================
C
C  TOLMUL  Real*8, default = max(10,min(100,EPS**(-1/8)))
C          TOLMUL controls the convergence criterion of the QR loop.
C          If it is positive, TOLMUL*EPS is the desired relative
C             precision in the computed singular values.
C          If it is negative, abs(TOLMUL*EPS*sigma_max) is the
C             desired absolute accuracy in the computed singular
C             values (corresponds to relative accuracy
C             abs(TOLMUL*EPS) in the largest singular value.
C          abs(TOLMUL) should be between 1 and 1/EPS, and preferably
C             between 10 (for fast convergence) and .1/EPS
C             (for there to be some accuracy in the results).
C          Default is to lose at either one eighth or 2 of the
C             available decimal digits in each computed singular value
C             (whichever is smaller).
C
C  MAXITR  INTEGER, default = 6
C          MAXITR controls the maximum number of passes of the
C          algorithm through its inner loop. The algorithms stops
C          (and so fails to converge) if the number of passes
C          through the inner loop exceeds MAXITR*N**2.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      Real*8   ONE
      PARAMETER          ( ONE = 1.0D0 )
      Real*8   NEGONE
      PARAMETER          ( NEGONE = -1.0D0 )
      Real*8   HNDRTH
      PARAMETER          ( HNDRTH = 0.01D0 )
      Real*8   TEN
      PARAMETER          ( TEN = 10.0D0 )
      Real*8   HNDRD
      PARAMETER          ( HNDRD = 100.0D0 )
      Real*8   MEIGTH
      PARAMETER          ( MEIGTH = -0.125D0 )
      INTEGER            MAXITR
      PARAMETER          ( MAXITR = 6 )
C     ..
C     .. Local Scalars ..
      LOGICAL            ROTATE
      INTEGER            I, IDIR, IROT, ISUB, ITER, IUPLO, J, LL, LLL,
     $                   M, MAXIT, NM1, NM12, NM13, OLDLL, OLDM
      Real*8   ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
     $                   OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
     $                   SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
     $                   SN, THRESH, TOL, TOLMUL, UNFL
      LOGICAL            GLSAME
C
C     Test the input parameters.
C
      INFO = 0
      IUPLO = 0
      IF( GLSame( UPLO, 'U' ) )
     $   IUPLO = 1
      IF( GLSame( UPLO, 'L' ) )
     $   IUPLO = 2
      IF( IUPLO.EQ.0 ) 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) Call GLBErr('ZBDSQR',Info)
      If(N.eq.0) RETURN
      If(N.eq.1) GOTO 150
C
C     ROTATE is true if any singular vectors desired, false otherwise
C
      ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
C
C     If no singular vectors desired, use qd algorithm
C
      IF( .NOT.ROTATE ) THEN
         CALL DLASQ1( N, D, E, RWORK, INFO )
         RETURN
      END IF
C
      NM1 = N - 1
      NM12 = NM1 + NM1
      NM13 = NM12 + NM1
C
C     Get machine constants
C
      UNFL = SFMin
C
C     If matrix lower bidiagonal, rotate to be upper bidiagonal
C     by applying Givens rotations on the left
C
      IF( IUPLO.EQ.2 ) 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 )
            RWORK( I ) = CS
            RWORK( NM1+I ) = SN
   10    CONTINUE
C
C        Update singular vectors if desired
C
         IF( NRU.GT.0 )
     $      CALL ZLASR( 'R', 'V', 'F', NRU, N, RWORK( 1 ), RWORK( N ),
     $                  U, LDU )
         IF( NCC.GT.0 )
     $      CALL ZLASR( 'L', 'V', 'F', N, NCC, RWORK( 1 ), RWORK( N ),
     $                  C, LDC )
      END IF
C
C     Compute singular values to relative accuracy TOL
C     (By setting TOL to be negative, algorithm will compute
C     singular values to absolute accuracy ABS(TOL)*norm(input matrix))
C
      TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
      TOL = TOLMUL*EPS
C
C     Compute approximate maximum, minimum singular values
C
      SMAX = ABS( D( N ) )
      DO 20 I = 1, N - 1
         SMAX = MAX( SMAX, ABS( D( I ) ), ABS( E( I ) ) )
   20 CONTINUE
      SMINL = ZERO
      IF( TOL.GE.ZERO ) THEN
C
C        Relative accuracy desired
C
         SMINOA = ABS( D( 1 ) )
         IF( SMINOA.EQ.ZERO )
     $      GO TO 40
         MU = SMINOA
         DO 30 I = 2, N
            MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
            SMINOA = MIN( SMINOA, MU )
            IF( SMINOA.EQ.ZERO )
     $         GO TO 40
   30    CONTINUE
   40    CONTINUE
         SMINOA = SMINOA / SQRT( DBLE( N ) )
         THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
      ELSE
C
C        Absolute accuracy desired
C
         THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
      END IF
C
C     Prepare for main iteration loop for the singular values
C     (MAXIT is the maximum number of passes through the inner
C     loop permitted before nonconvergence signalled.)
C
      MAXIT = MAXITR*N*N
      ITER = 0
      OLDLL = -1
      OLDM = -1
C
C     M points to last element of unconverged part of matrix
C
      M = N
C
C     Begin main iteration loop
C
   50 CONTINUE
C
C     Check for convergence or exceeding iteration count
C
      IF( M.LE.1 )
     $   GO TO 150
      IF( ITER.GT.MAXIT )
     $   GO TO 190
C
C     Find diagonal block of matrix to work on
C
      IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
     $   D( M ) = ZERO
      SMAX = ABS( D( M ) )
      SMIN = SMAX
      DO 60 LLL = 1, M
         LL = M - LLL
         IF( LL.EQ.0 )
     $      GO TO 80
         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 70
         SMIN = MIN( SMIN, ABSS )
         SMAX = MAX( SMAX, ABSS, ABSE )
   60 CONTINUE
   70 CONTINUE
      E( LL ) = ZERO
C
C     Matrix splits since E(LL) = 0
C
      IF( LL.EQ.M-1 ) THEN
C
C        Convergence of bottom singular value, return to top of loop
C
         M = M - 1
         GO TO 50
      END IF
   80 CONTINUE
      LL = LL + 1
C
C     E(LL) through E(M-1) are nonzero, E(LL-1) is zero
C
      IF( LL.EQ.M-1 ) THEN
C
C        2 by 2 block, handle separately
C
         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
C
C        Compute singular vectors, if desired
C
         IF( NCVT.GT.0 )
     $      CALL ZDROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT,
     $                  COSR, SINR )
         IF( NRU.GT.0 )
     $      CALL ZDROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
         IF( NCC.GT.0 )
     $      CALL ZDROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
     $                  SINL )
         M = M - 2
         GO TO 50
      END IF
C
C     If working on new submatrix, choose shift direction
C     (from larger end diagonal element towards smaller)
C
      IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
         IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
C
C           Chase bulge from top (big end) to bottom (small end)
C
            IDIR = 1
         ELSE
C
C           Chase bulge from bottom (big end) to top (small end)
C
            IDIR = 2
         END IF
      END IF
C
C     Apply convergence tests
C
      IF( IDIR.EQ.1 ) THEN
C
C        Run convergence test in forward direction
C        First apply standard test to bottom of matrix
C
         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 50
         END IF
C
         IF( TOL.GE.ZERO ) THEN
C
C           If relative accuracy desired,
C           apply convergence criterion forward
C
            MU = ABS( D( LL ) )
            SMINL = MU
            DO 90 LLL = LL, M - 1
               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
                  E( LLL ) = ZERO
                  GO TO 50
               END IF
               MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
               SMINL = MIN( SMINL, MU )
   90       CONTINUE
         END IF
C
      ELSE
C
C        Run convergence test in backward direction
C        First apply standard test to top of matrix
C
         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 50
         END IF
C
         IF( TOL.GE.ZERO ) THEN
C
C           If relative accuracy desired,
C           apply convergence criterion backward
C
            MU = ABS( D( M ) )
            SMINL = MU
            DO 100 LLL = M - 1, LL, -1
               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
                  E( LLL ) = ZERO
                  GO TO 50
               END IF
               MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
               SMINL = MIN( SMINL, MU )
  100       CONTINUE
         END IF
      END IF
      OLDLL = LL
      OLDM = M
C
C     Compute shift.  First, test if shifting would ruin relative
C     accuracy, and if so set the shift to zero.
C
      IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
     $    MAX( EPS, HNDRTH*TOL ) ) THEN
C
C        Use a zero shift to avoid loss of relative accuracy
C
         SHIFT = ZERO
      ELSE
C
C        Compute the shift from 2-by-2 block at end of matrix
C
         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
C
C        Test if shift negligible, and if so set to zero
C
         IF( SLL.GT.ZERO ) THEN
            IF( ( SHIFT / SLL )**2.LT.EPS )
     $         SHIFT = ZERO
         END IF
      END IF
C
C     Increment iteration count
C
      ITER = ITER + M - LL
C
C     If SHIFT = 0, do simplified QR iteration
C
      IF( SHIFT.EQ.ZERO ) THEN
         IF( IDIR.EQ.1 ) THEN
C
C           Chase bulge from top to bottom
C           Save cosines and sines for later singular vector updates
C
            CS = ONE
            OLDCS = ONE
            CALL DLARTG( D( LL )*CS, E( LL ), CS, SN, R )
            CALL DLARTG( OLDCS*R, D( LL+1 )*SN, OLDCS, OLDSN, D( LL ) )
            RWORK( 1 ) = CS
            RWORK( 1+NM1 ) = SN
            RWORK( 1+NM12 ) = OLDCS
            RWORK( 1+NM13 ) = OLDSN
            IROT = 1
            DO 110 I = LL + 1, M - 1
               CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
               E( I-1 ) = OLDSN*R
               CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
               IROT = IROT + 1
               RWORK( IROT ) = CS
               RWORK( IROT+NM1 ) = SN
               RWORK( IROT+NM12 ) = OLDCS
               RWORK( IROT+NM13 ) = OLDSN
  110       CONTINUE
            H = D( M )*CS
            D( M ) = H*OLDCS
            E( M-1 ) = H*OLDSN
C
C           Update singular vectors
C
            IF( NCVT.GT.0 )
     $         CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ),
     $                     RWORK( N ), VT( LL, 1 ), LDVT )
            IF( NRU.GT.0 )
     $         CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ),
     $                     RWORK( NM13+1 ), U( 1, LL ), LDU )
            IF( NCC.GT.0 )
     $         CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ),
     $                     RWORK( NM13+1 ), C( LL, 1 ), LDC )
C
C           Test convergence
C
            IF( ABS( E( M-1 ) ).LE.THRESH )
     $         E( M-1 ) = ZERO
C
         ELSE
C
C           Chase bulge from bottom to top
C           Save cosines and sines for later singular vector updates
C
            CS = ONE
            OLDCS = ONE
            CALL DLARTG( D( M )*CS, E( M-1 ), CS, SN, R )
            CALL DLARTG( OLDCS*R, D( M-1 )*SN, OLDCS, OLDSN, D( M ) )
            RWORK( M-LL ) = CS
            RWORK( M-LL+NM1 ) = -SN
            RWORK( M-LL+NM12 ) = OLDCS
            RWORK( M-LL+NM13 ) = -OLDSN
            IROT = M - LL
            DO 120 I = M - 1, LL + 1, -1
               CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
               E( I ) = OLDSN*R
               CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
               IROT = IROT - 1
               RWORK( IROT ) = CS
               RWORK( IROT+NM1 ) = -SN
               RWORK( IROT+NM12 ) = OLDCS
               RWORK( IROT+NM13 ) = -OLDSN
  120       CONTINUE
            H = D( LL )*CS
            D( LL ) = H*OLDCS
            E( LL ) = H*OLDSN
C
C           Update singular vectors
C
            IF( NCVT.GT.0 )
     $         CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ),
     $                     RWORK( NM13+1 ), VT( LL, 1 ), LDVT )
            IF( NRU.GT.0 )
     $         CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ),
     $                     RWORK( N ), U( 1, LL ), LDU )
            IF( NCC.GT.0 )
     $         CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ),
     $                     RWORK( N ), C( LL, 1 ), LDC )
C
C           Test convergence
C
            IF( ABS( E( LL ) ).LE.THRESH )
     $         E( LL ) = ZERO
         END IF
      ELSE
C
C        Use nonzero shift
C
         IF( IDIR.EQ.1 ) THEN
C
C           Chase bulge from top to bottom
C           Save cosines and sines for later singular vector updates
C
            F = ( ABS( D( LL ) )-SHIFT )*
     $          ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
            G = E( LL )
            CALL DLARTG( F, G, COSR, SINR, R )
            F = COSR*D( LL ) + SINR*E( LL )
            E( LL ) = COSR*E( LL ) - SINR*D( LL )
            G = SINR*D( LL+1 )
            D( LL+1 ) = COSR*D( LL+1 )
            CALL DLARTG( F, G, COSL, SINL, R )
            D( LL ) = R
            F = COSL*E( LL ) + SINL*D( LL+1 )
            D( LL+1 ) = COSL*D( LL+1 ) - SINL*E( LL )
            G = SINL*E( LL+1 )
            E( LL+1 ) = COSL*E( LL+1 )
            RWORK( 1 ) = COSR
            RWORK( 1+NM1 ) = SINR
            RWORK( 1+NM12 ) = COSL
            RWORK( 1+NM13 ) = SINL
            IROT = 1
            DO 130 I = LL + 1, M - 2
               CALL DLARTG( F, G, COSR, SINR, R )
               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 )
               G = SINL*E( I+1 )
               E( I+1 ) = COSL*E( I+1 )
               IROT = IROT + 1
               RWORK( IROT ) = COSR
               RWORK( IROT+NM1 ) = SINR
               RWORK( IROT+NM12 ) = COSL
               RWORK( IROT+NM13 ) = SINL
  130       CONTINUE
            CALL DLARTG( F, G, COSR, SINR, R )
            E( M-2 ) = R
            F = COSR*D( M-1 ) + SINR*E( M-1 )
            E( M-1 ) = COSR*E( M-1 ) - SINR*D( M-1 )
            G = SINR*D( M )
            D( M ) = COSR*D( M )
            CALL DLARTG( F, G, COSL, SINL, R )
            D( M-1 ) = R
            F = COSL*E( M-1 ) + SINL*D( M )
            D( M ) = COSL*D( M ) - SINL*E( M-1 )
            IROT = IROT + 1
            RWORK( IROT ) = COSR
            RWORK( IROT+NM1 ) = SINR
            RWORK( IROT+NM12 ) = COSL
            RWORK( IROT+NM13 ) = SINL
            E( M-1 ) = F
C
C           Update singular vectors
C
            IF( NCVT.GT.0 )
     $         CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ),
     $                     RWORK( N ), VT( LL, 1 ), LDVT )
            IF( NRU.GT.0 )
     $         CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ),
     $                     RWORK( NM13+1 ), U( 1, LL ), LDU )
            IF( NCC.GT.0 )
     $         CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ),
     $                     RWORK( NM13+1 ), C( LL, 1 ), LDC )
C
C           Test convergence
C
            IF( ABS( E( M-1 ) ).LE.THRESH )
     $         E( M-1 ) = ZERO
C
         ELSE
C
C           Chase bulge from bottom to top
C           Save cosines and sines for later singular vector updates
C
            F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
     $          D( M ) )
            G = E( M-1 )
            CALL DLARTG( F, G, COSR, SINR, R )
            F = COSR*D( M ) + SINR*E( M-1 )
            E( M-1 ) = COSR*E( M-1 ) - SINR*D( M )
            G = SINR*D( M-1 )
            D( M-1 ) = COSR*D( M-1 )
            CALL DLARTG( F, G, COSL, SINL, R )
            D( M ) = R
            F = COSL*E( M-1 ) + SINL*D( M-1 )
            D( M-1 ) = COSL*D( M-1 ) - SINL*E( M-1 )
            G = SINL*E( M-2 )
            E( M-2 ) = COSL*E( M-2 )
            RWORK( M-LL ) = COSR
            RWORK( M-LL+NM1 ) = -SINR
            RWORK( M-LL+NM12 ) = COSL
            RWORK( M-LL+NM13 ) = -SINL
            IROT = M - LL
            DO 140 I = M - 1, LL + 2, -1
               CALL DLARTG( F, G, COSR, SINR, R )
               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 )
               G = SINL*E( I-2 )
               E( I-2 ) = COSL*E( I-2 )
               IROT = IROT - 1
               RWORK( IROT ) = COSR
               RWORK( IROT+NM1 ) = -SINR
               RWORK( IROT+NM12 ) = COSL
               RWORK( IROT+NM13 ) = -SINL
  140       CONTINUE
            CALL DLARTG( F, G, COSR, SINR, R )
            E( LL+1 ) = R
            F = COSR*D( LL+1 ) + SINR*E( LL )
            E( LL ) = COSR*E( LL ) - SINR*D( LL+1 )
            G = SINR*D( LL )
            D( LL ) = COSR*D( LL )
            CALL DLARTG( F, G, COSL, SINL, R )
            D( LL+1 ) = R
            F = COSL*E( LL ) + SINL*D( LL )
            D( LL ) = COSL*D( LL ) - SINL*E( LL )
            IROT = IROT - 1
            RWORK( IROT ) = COSR
            RWORK( IROT+NM1 ) = -SINR
            RWORK( IROT+NM12 ) = COSL
            RWORK( IROT+NM13 ) = -SINL
            E( LL ) = F
C
C           Test convergence
C
            IF( ABS( E( LL ) ).LE.THRESH )
     $         E( LL ) = ZERO
C
C           Update singular vectors if desired
C
            IF( NCVT.GT.0 )
     $         CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ),
     $                     RWORK( NM13+1 ), VT( LL, 1 ), LDVT )
            IF( NRU.GT.0 )
     $         CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ),
     $                     RWORK( N ), U( 1, LL ), LDU )
            IF( NCC.GT.0 )
     $         CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ),
     $                     RWORK( N ), C( LL, 1 ), LDC )
         END IF
      END IF
C
C     QR iteration finished, go back and check convergence
C
      GO TO 50
C
C     All singular values converged, so make them positive
C
  150 CONTINUE
      DO 160 I = 1, N
         IF( D( I ).LT.ZERO ) THEN
            D( I ) = -D( I )
C
C           Change sign of singular vectors, if desired
C
            IF( NCVT.GT.0 )
     $         CALL YDScal( NCVT, NEGONE, VT( I, 1 ), LDVT )
         END IF
  160 CONTINUE
C
C     Sort the singular values into decreasing order (insertion sort on
C     singular values, but only one transposition per singular vector)
C
      DO 180 I = 1, N - 1
C
C        Scan for smallest D(I)
C
         ISUB = 1
         SMIN = D( 1 )
         DO 170 J = 2, N + 1 - I
            IF( D( J ).LE.SMIN ) THEN
               ISUB = J
               SMIN = D( J )
            END IF
  170    CONTINUE
         IF( ISUB.NE.N+1-I ) THEN
C
C           Swap singular values and vectors
C
            D( ISUB ) = D( N+1-I )
            D( N+1-I ) = SMIN
            IF( NCVT.GT.0 )
     $         CALL YSwap( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
     $                     LDVT )
            IF( NRU.GT.0 )
     $         CALL YSwap( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
            IF( NCC.GT.0 )
     $         CALL YSwap( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
         END IF
  180 CONTINUE
      GO TO 210
C
C     Maximum number of iterations exceeded, failure to converge
C
  190 CONTINUE
      INFO = 0
      DO 200 I = 1, N - 1
         IF( E( I ).NE.ZERO )
     $      INFO = INFO + 1
  200 CONTINUE
  210 CONTINUE
      RETURN
      END
*Deck ZDRot
      SUBROUTINE ZDROT( N, CX, INCX, CY, INCY, C, S )
      Implicit Real*8(A-H,O-Z)
C
C     applies a plane rotation, where the cos and sin (c and s) are real
C     and the vectors cx and cy are complex.
C     jack dongarra, linpack, 3/11/78.
C
C     .. Scalar Arguments ..
      INTEGER            INCX, INCY, N
      Real*8   C, S
C     ..
C     .. Array Arguments ..
      COMPLEX*16         CX( * ), CY( * )
C
C =====================================================================
C     ..
C     .. Local Scalars ..
      INTEGER            I, IX, IY
      COMPLEX*16         CTEMP
C     ..
C     .. Executable Statements ..
C
      IF( N.LE.0 )
     $   RETURN
      IF( INCX.EQ.1 .AND. INCY.EQ.1 )
     $   GO TO 20
C
C        code for unequal increments or equal increments not equal
C          to 1
C
      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
         CTEMP = C*CX( IX ) + S*CY( IY )
         CY( IY ) = C*CY( IY ) - S*CX( IX )
         CX( IX ) = CTEMP
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        code for both increments equal to 1
C
   20 CONTINUE
      DO 30 I = 1, N
         CTEMP = C*CX( I ) + S*CY( I )
         CY( I ) = C*CY( I ) - S*CX( I )
         CX( I ) = CTEMP
   30 CONTINUE
      RETURN
      END
*Deck ZGEBD2
      SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
C     ..
C     .. Array Arguments ..
      Real*8   D( * ), E( * )
      COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  ZGEBD2 reduces a complex general m by n matrix A to upper or lower
C  real bidiagonal form B by a unitary transformation: Q' * A * P = B.
C
C  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows in the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns in the matrix A.  N >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the m by n general matrix to be reduced.
C          On exit,
C          if m >= n, the diagonal and the first superdiagonal are
C            overwritten with the upper bidiagonal matrix B; the
C            elements below the diagonal, with the array TAUQ, represent
C            the unitary matrix Q as a product of elementary
C            reflectors, and the elements above the first superdiagonal,
C            with the array TAUP, represent the unitary matrix P as
C            a product of elementary reflectors;
C          if m < n, the diagonal and the first subdiagonal are
C            overwritten with the lower bidiagonal matrix B; the
C            elements below the first subdiagonal, with the array TAUQ,
C            represent the unitary matrix Q as a product of
C            elementary reflectors, and the elements above the diagonal,
C            with the array TAUP, represent the unitary matrix P as
C            a product of elementary reflectors.
C          See Further Details.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  D       (output) Real*8 array, dimension (min(M,N))
C          The diagonal elements of the bidiagonal matrix B:
C          D(i) = A(i,i).
C
C  E       (output) Real*8 array, dimension (min(M,N)-1)
C          The off-diagonal elements of the bidiagonal matrix B:
C          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
C          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
C
C  TAUQ    (output) COMPLEX*16 array dimension (min(M,N))
C          The scalar factors of the elementary reflectors which
C          represent the unitary matrix Q. See Further Details.
C
C  TAUP    (output) COMPLEX*16 array, dimension (min(M,N))
C          The scalar factors of the elementary reflectors which
C          represent the unitary matrix P. See Further Details.
C
C  WORK    (workspace) COMPLEX*16 array, dimension (max(M,N))
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument had an illegal value.
C
C  Further Details
C  ===============
C
C  The matrices Q and P are represented as products of elementary
C  reflectors:
C
C  If m >= n,
C
C     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
C
C  Each H(i) and G(i) has the form:
C
C     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
C
C  where tauq and taup are complex scalars, and v and u are complex
C  vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
C  A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
C  A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
C
C  If m < n,
C
C     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
C
C  Each H(i) and G(i) has the form:
C
C     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
C
C  where tauq and taup are complex scalars, v and u are complex vectors;
C  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
C  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
C  tauq is stored in TAUQ(i) and taup in TAUP(i).
C
C  The contents of A on exit are illustrated by the following examples:
C
C  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
C
C    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
C    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
C    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
C    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
C    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
C    (  v1  v2  v3  v4  v5 )
C
C  where d and e denote diagonal and off-diagonal elements of B, vi
C  denotes an element of the vector defining H(i), and ui an element of
C  the vector defining G(i).
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ZERO, ONE
      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
      INTEGER            I
      COMPLEX*16         ALPHA, GCONJG
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters
C
      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) Call GLBErr('ZGEBD2',Info)
      IF( M.GE.N ) THEN
C
C        Reduce to upper bidiagonal form
C
         DO 10 I = 1, N
C
C           Generate elementary reflector H(i) to annihilate A(i+1:m,i)
C
            ALPHA = A( I, I )
            CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
     $                   TAUQ( I ) )
            D( I ) = ALPHA
            A( I, I ) = ONE
C
C           Apply H(i)' to A(i:m,i+1:n) from the left
C
            CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
     $                  GCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK )
            A( I, I ) = D( I )
C
            IF( I.LT.N ) THEN
C
C              Generate elementary reflector G(i) to annihilate
C              A(i,i+2:n)
C
               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
               ALPHA = A( I, I+1 )
               CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
     $                      TAUP( I ) )
               E( I ) = ALPHA
               A( I, I+1 ) = ONE
C
C              Apply G(i) to A(i+1:m,i+1:n) from the right
C
               CALL ZLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
     $                     TAUP( I ), A( I+1, I+1 ), LDA, WORK )
               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
               A( I, I+1 ) = E( I )
            ELSE
               TAUP( I ) = ZERO
            END IF
   10    CONTINUE
      ELSE
C
C        Reduce to lower bidiagonal form
C
         DO 20 I = 1, M
C
C           Generate elementary reflector G(i) to annihilate A(i,i+1:n)
C
            CALL ZLACGV( N-I+1, A( I, I ), LDA )
            ALPHA = A( I, I )
            CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
     $                   TAUP( I ) )
            D( I ) = ALPHA
            A( I, I ) = ONE
C
C           Apply G(i) to A(i+1:m,i:n) from the right
C
            CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ),
     $                  A( MIN( I+1, M ), I ), LDA, WORK )
            CALL ZLACGV( N-I+1, A( I, I ), LDA )
            A( I, I ) = D( I )
C
            IF( I.LT.M ) THEN
C
C              Generate elementary reflector H(i) to annihilate
C              A(i+2:m,i)
C
               ALPHA = A( I+1, I )
               CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
     $                      TAUQ( I ) )
               E( I ) = ALPHA
               A( I+1, I ) = ONE
C
C              Apply H(i)' to A(i+1:m,i+1:n) from the left
C
               CALL ZLARF( 'Left', M-I, N-I, A( I+1, I ), 1,
     $                     GCONJG( 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
*Deck ZGEBrd
      SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
     $                   INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
C     ..
C     .. Array Arguments ..
      Real*8   D( * ), E( * )
      COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ),
     $                   WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  ZGEBRD reduces a general complex M-by-N matrix A to upper or lower
C  bidiagonal form B by a unitary transformation: Q**H * A * P = B.
C
C  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows in the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns in the matrix A.  N >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the M-by-N general matrix to be reduced.
C          On exit,
C          if m >= n, the diagonal and the first superdiagonal are
C            overwritten with the upper bidiagonal matrix B; the
C            elements below the diagonal, with the array TAUQ, represent
C            the unitary matrix Q as a product of elementary
C            reflectors, and the elements above the first superdiagonal,
C            with the array TAUP, represent the unitary matrix P as
C            a product of elementary reflectors;
C          if m < n, the diagonal and the first subdiagonal are
C            overwritten with the lower bidiagonal matrix B; the
C            elements below the first subdiagonal, with the array TAUQ,
C            represent the unitary matrix Q as a product of
C            elementary reflectors, and the elements above the diagonal,
C            with the array TAUP, represent the unitary matrix P as
C            a product of elementary reflectors.
C          See Further Details.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  D       (output) Real*8 array, dimension (min(M,N))
C          The diagonal elements of the bidiagonal matrix B:
C          D(i) = A(i,i).
C
C  E       (output) Real*8 array, dimension (min(M,N)-1)
C          The off-diagonal elements of the bidiagonal matrix B:
C          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
C          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
C
C  TAUQ    (output) COMPLEX*16 array dimension (min(M,N))
C          The scalar factors of the elementary reflectors which
C          represent the unitary matrix Q. See Further Details.
C
C  TAUP    (output) COMPLEX*16 array, dimension (min(M,N))
C          The scalar factors of the elementary reflectors which
C          represent the unitary matrix P. See Further Details.
C
C  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The length of the array WORK.  LWORK >= max(1,M,N).
C          For optimum performance LWORK >= (M+N)*NB, where NB
C          is the optimal blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit.
C          < 0:  if INFO = -i, the i-th argument had an illegal value.
C
C  Further Details
C  ===============
C
C  The matrices Q and P are represented as products of elementary
C  reflectors:
C
C  If m >= n,
C
C     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
C
C  Each H(i) and G(i) has the form:
C
C     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
C
C  where tauq and taup are complex scalars, and v and u are complex
C  vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
C  A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
C  A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
C
C  If m < n,
C
C     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
C
C  Each H(i) and G(i) has the form:
C
C     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
C
C  where tauq and taup are complex scalars, and v and u are complex
C  vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in
C  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in
C  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
C
C  The contents of A on exit are illustrated by the following examples:
C
C  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
C
C    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
C    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
C    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
C    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
C    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
C    (  v1  v2  v3  v4  v5 )
C
C  where d and e denote diagonal and off-diagonal elements of B, vi
C  denotes an element of the vector defining H(i), and ui an element of
C  the vector defining G(i).
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IINFO, J, LDWRKX, LDWRKY, MINMN, NB, NBMIN,
     $                   NX
      Real*8   WS
C     ..
C     .. External Functions ..
      INTEGER            ILAENV
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters
C
      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
      ELSE IF( LWORK.LT.MAX( 1, M, N ) ) THEN
         INFO = -10
      END IF
      If(Info.lt.0) Call GLBErr('ZGEBrd',Info)
C
C     Quick return if possible
C
      MINMN = MIN( M, N )
      IF( MINMN.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
C
      WS = MAX( M, N )
      LDWRKX = M
      LDWRKY = N
C
C     Set the block size NB and the crossover point NX.
C
      NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) )
C
      IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
C
C        Determine when to switch from blocked to unblocked code.
C
         NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) )
         IF( NX.LT.MINMN ) THEN
            WS = ( M+N )*NB
            IF( LWORK.LT.WS ) THEN
C
C              Not enough work space for the optimal NB, consider using
C              a smaller block size.
C
               NBMIN = ILAENV( 2, 'ZGEBRD', ' ', 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
C
      DO 30 I = 1, MINMN - NX, NB
C
C        Reduce rows and columns i:i+ib-1 to bidiagonal form and return
C        the matrices X and Y which are needed to update the unreduced
C        part of the matrix
C
         CALL ZLABRD( 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 )
C
C        Update the trailing submatrix A(i+ib:m,i+ib:n), using
C        an update of the form  A := A - V*Y' - X*U'
C
         CALL YGEMM( 'No transpose', 'Conjugate 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 YGEMM( '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 )
C
C        Copy diagonal and off-diagonal elements of B back into A
C
         IF( M.GE.N ) THEN
            DO 10 J = I, I + NB - 1
               A( J, J ) = D( J )
               A( J, J+1 ) = E( J )
   10       CONTINUE
         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
C
C     Use unblocked code to reduce the remainder of the matrix
C
      CALL ZGEBD2( 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
*Deck ZGELQ2
      SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  ZGELQ2 computes an LQ factorization of a complex m by n matrix A:
C  A = L * Q.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the m by n matrix A.
C          On exit, the elements on and below the diagonal of the array
C          contain the m by min(m,n) lower trapezoidal matrix L (L is
C          lower triangular if m <= n); the elements above the diagonal,
C          with the array TAU, represent the unitary matrix Q as a
C          product of elementary reflectors (see Further Details).
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
C          The scalar factors of the elementary reflectors (see Further
C          Details).
C
C  WORK    (workspace) COMPLEX*16 array, dimension (M)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument had an illegal value
C
C  Further Details
C  ===============
C
C  The matrix Q is represented as a product of elementary reflectors
C
C     Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a complex scalar, and v is a complex vector with
C  v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
C  A(i,i+1:n), and tau in TAU(i).
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      INTEGER            I, K
      COMPLEX*16         ALPHA
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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) Call GLBErr('ZGELQ2',Info)
      K = MIN( M, N )
      DO 10 I = 1, K
C
C        Generate elementary reflector H(i) to annihilate A(i,i+1:n)
C
         CALL ZLACGV( N-I+1, A( I, I ), LDA )
         ALPHA = A( I, I )
         CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
     $                TAU( I ) )
         IF( I.LT.M ) THEN
C
C           Apply H(i) to A(i+1:m,i:n) from the right
C
            A( I, I ) = ONE
            CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
     $                  A( I+1, I ), LDA, WORK )
         END IF
         A( I, I ) = ALPHA
         CALL ZLACGV( N-I+1, A( I, I ), LDA )
   10 CONTINUE
      RETURN
      END
*Deck ZGelQF
      SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
      Implicit Real*8 (A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  ZGELQF computes an LQ factorization of a complex M-by-N matrix A:
C  A = L * Q.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the M-by-N matrix A.
C          On exit, the elements on and below the diagonal of the array
C          contain the m-by-min(m,n) lower trapezoidal matrix L (L is
C          lower triangular if m <= n); the elements above the diagonal,
C          with the array TAU, represent the unitary matrix Q as a
C          product of elementary reflectors (see Further Details).
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
C          The scalar factors of the elementary reflectors (see Further
C          Details).
C
C  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK.  LWORK >= max(1,M).
C          For optimum performance LWORK >= M*NB, where NB is the
C          optimal blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  Further Details
C  ===============
C
C  The matrix Q is represented as a product of elementary reflectors
C
C     Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a complex scalar, and v is a complex vector with
C  v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
C  A(i,i+1:n), and tau in TAU(i).
C
C  =====================================================================
C
C     .. Local Scalars ..
      INTEGER            I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX
      INTEGER            ILAENV
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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
      ELSE IF( LWORK.LT.MAX( 1, M ) ) THEN
         INFO = -7
      END IF
      If(Info.ne.0) Call GLBErr('ZGelQF',Info)
      WORK( 1 ) = 1
      K = MIN( M, N )
      If(K.eq.0) RETURN
C
C     Determine the block size.
C
      NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
      NBMIN = 2
      NX = 0
      IWS = M
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
C
C        Determine when to cross over from blocked to unblocked code.
C
         NX = MAX( 0, ILAENV( 3, 'ZGELQF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.K ) THEN
C
C           Determine if workspace is large enough for blocked code.
C
            LDWORK = M
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
C
C              Not enough workspace to use optimal NB:  reduce NB and
C              determine the minimum value of NB.
C
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'ZGELQF', ' ', M, N, -1,
     $                 -1 ) )
            END IF
         END IF
      END IF
C
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
C
C        Use blocked code initially
C
         DO 10 I = 1, K - NX, NB
            IB = MIN( K-I+1, NB )
C
C           Compute the LQ factorization of the current block
C           A(i:i+ib-1,i:n)
C
            CALL ZGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
     $                   IINFO )
            IF( I+IB.LE.M ) THEN
C
C              Form the triangular factor of the block reflector
C              H = H(i) H(i+1) . . . H(i+ib-1)
C
               CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
     $                      LDA, TAU( I ), WORK, LDWORK )
C
C              Apply H to A(i+ib:m,i:n) from the right
C
               CALL ZLARFB( '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
C
C     Use unblocked code to factor the last or only block.
C
      IF( I.LE.K )
     $   CALL ZGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
     $                IINFO )
C
      WORK( 1 ) = IWS
      RETURN
      END
*Deck ZGEQR2
      SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  ZGEQR2 computes a QR factorization of a complex m by n matrix A:
C  A = Q * R.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the m by n matrix A.
C          On exit, the elements on and above the diagonal of the array
C          contain the min(m,n) by n upper trapezoidal matrix R (R is
C          upper triangular if m >= n); the elements below the diagonal,
C          with the array TAU, represent the unitary matrix Q as a
C          product of elementary reflectors (see Further Details).
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
C          The scalar factors of the elementary reflectors (see Further
C          Details).
C
C  WORK    (workspace) COMPLEX*16 array, dimension (N)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument had an illegal value
C
C  Further Details
C  ===============
C
C  The matrix Q is represented as a product of elementary reflectors
C
C     Q = H(1) H(2) . . . H(k), where k = min(m,n).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a complex scalar, and v is a complex vector with
C  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
C  and tau in TAU(i).
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      INTEGER            I, K
      COMPLEX*16         ALPHA, GCONJG
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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) Call GLBErr('ZGEQR2',Info)
      K = MIN( M, N )
      DO 10 I = 1, K
C
C        Generate elementary reflector H(i) to annihilate A(i+1:m,i)
C
         CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
     $                TAU( I ) )
         IF( I.LT.N ) THEN
C
C           Apply H(i)' to A(i:m,i+1:n) from the left
C
            ALPHA = A( I, I )
            A( I, I ) = ONE
            CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
     $                  GCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
            A( I, I ) = ALPHA
         END IF
   10 CONTINUE
      RETURN
      END
*Deck ZGEQRF
      SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  ZGEQRF computes a QR factorization of a complex M-by-N matrix A:
C  A = Q * R.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the M-by-N matrix A.
C          On exit, the elements on and above the diagonal of the array
C          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
C          upper triangular if m >= n); the elements below the diagonal,
C          with the array TAU, represent the unitary matrix Q as a
C          product of min(m,n) elementary reflectors (see Further
C          Details).
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
C          The scalar factors of the elementary reflectors (see Further
C          Details).
C
C  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK.  LWORK >= max(1,N).
C          For optimum performance LWORK >= N*NB, where NB is
C          the optimal blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  Further Details
C  ===============
C
C  The matrix Q is represented as a product of elementary reflectors
C
C     Q = H(1) H(2) . . . H(k), where k = min(m,n).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a complex scalar, and v is a complex vector with
C  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
C  and tau in TAU(i).
C
C  =====================================================================
C
C     .. Local Scalars ..
      INTEGER            I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX
      INTEGER            ILAENV
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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
      ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      If(Info.ne.0) Call GLBErr('ZGEQRF',Info)
      WORK( 1 ) = 1
      K = MIN( M, N )
      If(K.eq.0) RETURN
C
C     Determine the block size.
C
      NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
      NBMIN = 2
      NX = 0
      IWS = N
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
C
C        Determine when to cross over from blocked to unblocked code.
C
         NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.K ) THEN
C
C           Determine if workspace is large enough for blocked code.
C
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
C
C              Not enough workspace to use optimal NB:  reduce NB and
C              determine the minimum value of NB.
C
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'ZGEQRF', ' ', M, N, -1,
     $                 -1 ) )
            END IF
         END IF
      END IF
C
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
C
C        Use blocked code initially
C
         DO 10 I = 1, K - NX, NB
            IB = MIN( K-I+1, NB )
C
C           Compute the QR factorization of the current block
C           A(i:m,i:i+ib-1)
C
            CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
     $                   IINFO )
            IF( I+IB.LE.N ) THEN
C
C              Form the triangular factor of the block reflector
C              H = H(i) H(i+1) . . . H(i+ib-1)
C
               CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB,
     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
C
C              Apply H' to A(i:m,i+ib:n) from the left
C
               CALL ZLARFB( 'Left', 'Conjugate 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
C
C     Use unblocked code to factor the last or only block.
C
      IF( I.LE.K )
     $   CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
     $                IINFO )
C
      WORK( 1 ) = IWS
      RETURN
      END
*Deck ZGESVD
      Subroutine ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
     $  WORK, LWORK, RWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK driver routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
      CHARACTER          JOBU, JOBVT
      INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
      Real*8   RWORK( * ), S( * )
      COMPLEX*16         A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
     $  WORK( * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  ZGESVD computes the singular value decomposition (SVD) of a complex
C  M-by-N matrix A, optionally computing the left and/or right singular
C  vectors. The SVD is written
C
C       A = U * SIGMA * conjugate-transpose(V)
C
C  where SIGMA is an M-by-N matrix which is zero except for its
C  min(m,n) diagonal elements, U is an M-by-M unitary matrix, and
C  V is an N-by-N unitary matrix.  The diagonal elements of SIGMA
C  are the singular values of A; they are real and non-negative, and
C  are returned in descending order.  The first min(m,n) columns of
C  U and V are the left and right singular vectors of A.
C
C  Note that the routine returns V**H, not V.
C
C  Arguments
C  =========
C
C  JOBU    (input) CHARACTER*1
C          Specifies options for computing all or part of the matrix U:
C          = 'A':  all M columns of U are returned in array U:
C          = 'S':  the first min(m,n) columns of U (the left singular
C                  vectors) are returned in the array U;
C          = 'O':  the first min(m,n) columns of U (the left singular
C                  vectors) are overwritten on the array A;
C          = 'N':  no columns of U (no left singular vectors) are
C                  computed.
C
C  JOBVT   (input) CHARACTER*1
C          Specifies options for computing all or part of the matrix
C          V**H:
C          = 'A':  all N rows of V**H are returned in the array VT;
C          = 'S':  the first min(m,n) rows of V**H (the right singular
C                  vectors) are returned in the array VT;
C          = 'O':  the first min(m,n) rows of V**H (the right singular
C                  vectors) are overwritten on the array A;
C          = 'N':  no rows of V**H (no right singular vectors) are
C                  computed.
C
C          JOBVT and JOBU cannot both be 'O'.
C
C  M       (input) INTEGER
C          The number of rows of the input matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the input matrix A.  N >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the M-by-N matrix A.
C          On exit,
C          if JOBU = 'O',  A is overwritten with the first min(m,n)
C                          columns of U (the left singular vectors,
C                          stored columnwise);
C          if JOBVT = 'O', A is overwritten with the first min(m,n)
C                          rows of V**H (the right singular vectors,
C                          stored rowwise);
C          if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
C                          are destroyed.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  S       (output) Real*8 array, dimension (min(M,N))
C          The singular values of A, sorted so that S(i) >= S(i+1).
C
C  U       (output) COMPLEX*16 array, dimension (LDU,UCOL)
C          (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
C          If JOBU = 'A', U contains the M-by-M unitary matrix U;
C          if JOBU = 'S', U contains the first min(m,n) columns of U
C          (the left singular vectors, stored columnwise);
C          if JOBU = 'N' or 'O', U is not referenced.
C
C  LDU     (input) INTEGER
C          The leading dimension of the array U.  LDU >= 1; if
C          JOBU = 'S' or 'A', LDU >= M.
C
C  VT      (output) COMPLEX*16 array, dimension (LDVT,N)
C          If JOBVT = 'A', VT contains the N-by-N unitary matrix
C          V**H;
C          if JOBVT = 'S', VT contains the first min(m,n) rows of
C          V**H (the right singular vectors, stored rowwise);
C          if JOBVT = 'N' or 'O', VT is not referenced.
C
C  LDVT    (input) INTEGER
C          The leading dimension of the array VT.  LDVT >= 1; if
C          JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
C
C  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK. LWORK >= 1.
C          LWORK >=  2*MIN(M,N)+MAX(M,N).
C          For good performance, LWORK should generally be larger.
C
C  RWORK   (workspace) Real*8 array, dimension
C                                  (max(3*min(M,N),5*min(M,N)-4))
C          On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the
C          unconverged superdiagonal elements of an upper bidiagonal
C          matrix B whose diagonal is in S (not necessarily sorted).
C          B satisfies A = U * B * VT, so it has the same singular
C          values as A, and singular vectors related by U and VT.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit.
C          < 0:  if INFO = -i, the i-th argument had an illegal value.
C          > 0:  if ZBDSQR did not converge, INFO specifies how many
C                superdiagonals of an intermediate bidiagonal form B
C                did not converge to zero. See the description of RWORK
C                above for details.
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
     $                   CONE = ( 1.0D0, 0.0D0 ) )
      Real*8   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, WNTVA,
     $                   WNTVAS, WNTVN, WNTVO, WNTVS
      INTEGER            BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL,
     $                   ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
     $                   MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
     $                   NRVT, WRKBL
      Real*8   ANRM, BIGNUM, EPS, SMLNUM
C     ..
C     .. Local Arrays ..
      Real*8   DUM( 1 )
      COMPLEX*16         CDUM( 1 )
C     ..
C     .. External Subroutines ..
      LOGICAL            GLSAME
      INTEGER            ILAENV
      Real*8   ZLANGE
C
C     Test the input arguments
C
      INFO = 0
      MINMN = MIN( M, N )
      MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 )
      WNTUA = GLSame( JOBU, 'A' )
      WNTUS = GLSame( JOBU, 'S' )
      WNTUAS = WNTUA .OR. WNTUS
      WNTUO = GLSame( JOBU, 'O' )
      WNTUN = GLSame( JOBU, 'N' )
      WNTVA = GLSame( JOBVT, 'A' )
      WNTVS = GLSame( JOBVT, 'S' )
      WNTVAS = WNTVA .OR. WNTVS
      WNTVO = GLSame( JOBVT, 'O' )
      WNTVN = GLSame( JOBVT, 'N' )
      MINWRK = 1
C
      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
C
C     Compute workspace
C      (Note: Comments in the code beginning "Workspace:" describe the
C       minimal amount of workspace needed at that point in the code,
C       as well as the preferred amount for good performance.
C       CWorkspace refers to complex workspace, and RWorkspace to
C       real workspace. NB refers to the optimal block size for the
C       immediately following subroutine, as returned by ILAENV.)
C
      IF( INFO.EQ.0 .AND. LWORK.GE.1 .AND. M.GT.0 .AND. N.GT.0 ) THEN
         IF( M.GE.N ) THEN
C
C           Space needed for ZBDSQR is BDSPAC = MAX( 3*N, 5*N-4 )
C
            IF( M.GE.MNTHR ) THEN
               IF( WNTUN ) THEN
C
C                 Path 1 (M much larger than N, JOBU='N')
C
                  MAXWRK = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1,
     $                     -1 )
                  MAXWRK = MAX( MAXWRK, 2*N+2*N*
     $                     ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
                  IF( WNTVO .OR. WNTVAS )
     $               MAXWRK = MAX( MAXWRK, 2*N+( N-1 )*
     $                        ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
                  MINWRK = 3*N
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTUO .AND. WNTVN ) THEN
C
C                 Path 2 (M much larger than N, JOBU='O', JOBVT='N')
C
                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M,
     $                    N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+2*N*
     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+N*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
                  MAXWRK = MAX( N*N+WRKBL, N*N+M*N )
                  MINWRK = 2*N + M
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTUO .AND. WNTVAS ) THEN
C
C                 Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
C                 'A')
C
                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M,
     $                    N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+2*N*
     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+N*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
                  MAXWRK = MAX( N*N+WRKBL, N*N+M*N )
                  MINWRK = 2*N + M
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTUS .AND. WNTVN ) THEN
C
C                 Path 4 (M much larger than N, JOBU='S', JOBVT='N')
C
                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M,
     $                    N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+2*N*
     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+N*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
                  MAXWRK = N*N + WRKBL
                  MINWRK = 2*N + M
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTUS .AND. WNTVO ) THEN
C
C                 Path 5 (M much larger than N, JOBU='S', JOBVT='O')
C
                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M,
     $                    N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+2*N*
     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+N*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
                  MAXWRK = 2*N*N + WRKBL
                  MINWRK = 2*N + M
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTUS .AND. WNTVAS ) THEN
C
C                 Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
C                 'A')
C
                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M,
     $                    N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+2*N*
     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+N*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
                  MAXWRK = N*N + WRKBL
                  MINWRK = 2*N + M
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTUA .AND. WNTVN ) THEN
C
C                 Path 7 (M much larger than N, JOBU='A', JOBVT='N')
C
                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M,
     $                    M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+2*N*
     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+N*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
                  MAXWRK = N*N + WRKBL
                  MINWRK = 2*N + M
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTUA .AND. WNTVO ) THEN
C
C                 Path 8 (M much larger than N, JOBU='A', JOBVT='O')
C
                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M,
     $                    M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+2*N*
     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+N*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
                  MAXWRK = 2*N*N + WRKBL
                  MINWRK = 2*N + M
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTUA .AND. WNTVAS ) THEN
C
C                 Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
C                 'A')
C
                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M,
     $                    M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+2*N*
     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+N*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
                  MAXWRK = N*N + WRKBL
                  MINWRK = 2*N + M
                  MAXWRK = MAX( MINWRK, MAXWRK )
               END IF
            ELSE
C
C              Path 10 (M at least N, but not much larger)
C
               MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
     $                  -1, -1 )
               IF( WNTUS .OR. WNTUO )
     $            MAXWRK = MAX( MAXWRK, 2*N+N*
     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, N, N, -1 ) )
               IF( WNTUA )
     $            MAXWRK = MAX( MAXWRK, 2*N+M*
     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) )
               IF( .NOT.WNTVN )
     $            MAXWRK = MAX( MAXWRK, 2*N+( N-1 )*
     $                     ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
               MINWRK = 2*N + M
               MAXWRK = MAX( MINWRK, MAXWRK )
            END IF
         ELSE
C
C           Space needed for ZBDSQR is BDSPAC = MAX( 3*M, 5*M-4 )
C
            IF( N.GE.MNTHR ) THEN
               IF( WNTVN ) THEN
C
C                 Path 1t(N much larger than M, JOBVT='N')
C
                  MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1,
     $                     -1 )
                  MAXWRK = MAX( MAXWRK, 2*M+2*M*
     $                     ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  IF( WNTUO .OR. WNTUAS )
     $               MAXWRK = MAX( MAXWRK, 2*M+M*
     $                        ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
                  MINWRK = 3*M
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTVO .AND. WNTUN ) THEN
C
C                 Path 2t(N much larger than M, JOBU='N', JOBVT='O')
C
                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+2*M*
     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
                  MAXWRK = MAX( M*M+WRKBL, M*M+M*N )
                  MINWRK = 2*M + N
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTVO .AND. WNTUAS ) THEN
C
C                 Path 3t(N much larger than M, JOBU='S' or 'A',
C                 JOBVT='O')
C
                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+2*M*
     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+M*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
                  MAXWRK = MAX( M*M+WRKBL, M*M+M*N )
                  MINWRK = 2*M + N
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTVS .AND. WNTUN ) THEN
C
C                 Path 4t(N much larger than M, JOBU='N', JOBVT='S')
C
                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+2*M*
     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
                  MAXWRK = M*M + WRKBL
                  MINWRK = 2*M + N
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTVS .AND. WNTUO ) THEN
C
C                 Path 5t(N much larger than M, JOBU='O', JOBVT='S')
C
                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+2*M*
     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+M*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
                  MAXWRK = 2*M*M + WRKBL
                  MINWRK = 2*M + N
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTVS .AND. WNTUAS ) THEN
C
C                 Path 6t(N much larger than M, JOBU='S' or 'A',
C                 JOBVT='S')
C
                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+2*M*
     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+M*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
                  MAXWRK = M*M + WRKBL
                  MINWRK = 2*M + N
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTVA .AND. WNTUN ) THEN
C
C                 Path 7t(N much larger than M, JOBU='N', JOBVT='A')
C
                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+2*M*
     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
                  MAXWRK = M*M + WRKBL
                  MINWRK = 2*M + N
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTVA .AND. WNTUO ) THEN
C
C                 Path 8t(N much larger than M, JOBU='O', JOBVT='A')
C
                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+2*M*
     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+M*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
                  MAXWRK = 2*M*M + WRKBL
                  MINWRK = 2*M + N
                  MAXWRK = MAX( MINWRK, MAXWRK )
               ELSE IF( WNTVA .AND. WNTUAS ) THEN
C
C                 Path 9t(N much larger than M, JOBU='S' or 'A',
C                 JOBVT='A')
C
                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+2*M*
     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+M*
     $                    ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
                  MAXWRK = M*M + WRKBL
                  MINWRK = 2*M + N
                  MAXWRK = MAX( MINWRK, MAXWRK )
               END IF
            ELSE
C
C              Path 10t(N greater than M, but not much larger)
C
               MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
     $                  -1, -1 )
               IF( WNTVS .OR. WNTVO )
     $            MAXWRK = MAX( MAXWRK, 2*M+M*
     $                     ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) )
               IF( WNTVA )
     $            MAXWRK = MAX( MAXWRK, 2*M+N*
     $                     ILAENV( 1, 'ZUNGBR', 'P', N, N, M, -1 ) )
               IF( .NOT.WNTUN )
     $            MAXWRK = MAX( MAXWRK, 2*M+( M-1 )*
     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
               MINWRK = 2*M + N
               MAXWRK = MAX( MINWRK, MAXWRK )
            END IF
         END IF
         WORK( 1 ) = MAXWRK
      END IF
C
      IF( LWORK.LT.MINWRK ) THEN
         INFO = -13
      END IF
      If(Info.ne.0) Call GLBErr('ZGESVD',Info)
C
C     Quick return if possible
C
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         IF( LWORK.GE.1 )
     $      WORK( 1 ) = ONE
         RETURN
      END IF
C
C     Get machine constants
C
      SMLNUM = SQRT( SFMin ) / EPS
      BIGNUM = ONE / SMLNUM
C
C     Scale A if max element outside range [SMLNUM,BIGNUM]
C
      ANRM = ZLANGE( 'M', M, N, A, LDA, DUM )
      ISCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ISCL = 1
         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ISCL = 1
         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
      END IF
C
      IF( M.GE.N ) THEN
C
C        A has at least as many rows as columns. If A has sufficiently
C        more rows than columns, first reduce using the QR
C        decomposition (if sufficient workspace available)
C
         IF( M.GE.MNTHR ) THEN
C
            IF( WNTUN ) THEN
C
C              Path 1 (M much larger than N, JOBU='N')
C              No left singular vectors to be computed
C
               ITAU = 1
               IWORK = ITAU + N
C
C              Compute A=Q*R
C              (CWorkspace: need 2*N, prefer N+N*NB)
C              (RWorkspace: need 0)
C
               CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
     $                      LWORK-IWORK+1, IERR )
C
C              Zero out below R
C
               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
     $                      LDA )
               IE = 1
               ITAUQ = 1
               ITAUP = ITAUQ + N
               IWORK = ITAUP + N
C
C              Bidiagonalize R in A
C              (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
C              (RWorkspace: need N)
C
               CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
     $                      WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
     $                      IERR )
               NCVT = 0
               IF( WNTVO .OR. WNTVAS ) THEN
C
C                 If right singular vectors desired, generate P'.
C                 (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  NCVT = N
               END IF
               IRWORK = IE + N
C
C              Perform bidiagonal QR iteration, computing right
C              singular vectors of A in A if desired
C              (CWorkspace: 0)
C              (RWorkspace: need BDSPAC)
C
               CALL ZBDSQR( 'U', N, NCVT, 0, 0, S, RWORK( IE ), A, LDA,
     $                      CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO )
C
C              If right singular vectors desired in VT, copy them there
C
               IF( WNTVAS )
     $            CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT )
C
            ELSE IF( WNTUO .AND. WNTVN ) THEN
C
C              Path 2 (M much larger than N, JOBU='O', JOBVT='N')
C              N left singular vectors to be overwritten on A and
C              no right singular vectors to be computed
C
               IF( LWORK.GE.N*N+3*N ) THEN
C
C                 Sufficient workspace for a fast algorithm
C
                  IR = 1
                  IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN
C
C                    WORK(IU) is LDA by N, WORK(IR) is LDA by N
C
                     LDWRKU = LDA
                     LDWRKR = LDA
                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN
C
C                    WORK(IU) is LDA by N, WORK(IR) is N by N
C
                     LDWRKU = LDA
                     LDWRKR = N
                  ELSE
C
C                    WORK(IU) is LDWRKU by N, WORK(IR) is N by N
C
                     LDWRKU = ( LWORK-N*N ) / N
                     LDWRKR = N
                  END IF
                  ITAU = IR + LDWRKR*N
                  IWORK = ITAU + N
C
C                 Compute A=Q*R
C                 (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
C                 (RWorkspace: 0)
C
                  CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Copy R to WORK(IR) and zero out below it
C
                  CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
                  CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                         WORK( IR+1 ), LDWRKR )
C
C                 Generate Q in A
C                 (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IE = 1
                  ITAUQ = ITAU
                  ITAUP = ITAUQ + N
                  IWORK = ITAUP + N
C
C                 Bidiagonalize R in WORK(IR)
C                 (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
C                 (RWorkspace: need N)
C
                  CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Generate left vectors bidiagonalizing R
C                 (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
C                 (RWorkspace: need 0)
C
                  CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
     $                         WORK( ITAUQ ), WORK( IWORK ),
     $                         LWORK-IWORK+1, IERR )
                  IRWORK = IE + N
C
C                 Perform bidiagonal QR iteration, computing left
C                 singular vectors of R in WORK(IR)
C                 (CWorkspace: need N*N)
C                 (RWorkspace: need BDSPAC)
C
                  CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, 1,
     $                         WORK( IR ), LDWRKR, CDUM, 1,
     $                         RWORK( IRWORK ), INFO )
                  IU = ITAUQ
C
C                 Multiply Q in A by left singular vectors of R in
C                 WORK(IR), storing result in WORK(IU) and copying to A
C                 (CWorkspace: need N*N+N, prefer N*N+M*N)
C                 (RWorkspace: 0)
C
                  DO 10 I = 1, M, LDWRKU
                     CHUNK = MIN( M-I+1, LDWRKU )
                     CALL YGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
     $                           LDA, WORK( IR ), LDWRKR, CZERO,
     $                           WORK( IU ), LDWRKU )
                     CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
     $                            A( I, 1 ), LDA )
   10             CONTINUE
C
               ELSE
C
C                 Insufficient workspace for a fast algorithm
C
                  IE = 1
                  ITAUQ = 1
                  ITAUP = ITAUQ + N
                  IWORK = ITAUP + N
C
C                 Bidiagonalize A
C                 (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
C                 (RWorkspace: N)
C
                  CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Generate left vectors bidiagonalizing A
C                 (CWorkspace: need 3*N, prefer 2*N+N*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IRWORK = IE + N
C
C                 Perform bidiagonal QR iteration, computing left
C                 singular vectors of A in A
C                 (CWorkspace: need 0)
C                 (RWorkspace: need BDSPAC)
C
                  CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, 1,
     $                         A, LDA, CDUM, 1, RWORK( IRWORK ), INFO )
C
               END IF
C
            ELSE IF( WNTUO .AND. WNTVAS ) THEN
C
C              Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
C              N left singular vectors to be overwritten on A and
C              N right singular vectors to be computed in VT
C
               IF( LWORK.GE.N*N+3*N ) THEN
C
C                 Sufficient workspace for a fast algorithm
C
                  IR = 1
                  IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN
C
C                    WORK(IU) is LDA by N and WORK(IR) is LDA by N
C
                     LDWRKU = LDA
                     LDWRKR = LDA
                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN
C
C                    WORK(IU) is LDA by N and WORK(IR) is N by N
C
                     LDWRKU = LDA
                     LDWRKR = N
                  ELSE
C
C                    WORK(IU) is LDWRKU by N and WORK(IR) is N by N
C
                     LDWRKU = ( LWORK-N*N ) / N
                     LDWRKR = N
                  END IF
                  ITAU = IR + LDWRKR*N
                  IWORK = ITAU + N
C
C                 Compute A=Q*R
C                 (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
C                 (RWorkspace: 0)
C
                  CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Copy R to VT, zeroing out below it
C
                  CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
                  CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, VT( 2, 1 ),
     $                         LDVT )
C
C                 Generate Q in A
C                 (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IE = 1
                  ITAUQ = ITAU
                  ITAUP = ITAUQ + N
                  IWORK = ITAUP + N
C
C                 Bidiagonalize R in VT, copying result to WORK(IR)
C                 (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
C                 (RWorkspace: need N)
C
                  CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  CALL ZLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
C
C                 Generate left vectors bidiagonalizing R in WORK(IR)
C                 (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
     $                         WORK( ITAUQ ), WORK( IWORK ),
     $                         LWORK-IWORK+1, IERR )
C
C                 Generate right vectors bidiagonalizing R in VT
C                 (CWorkspace: need N*N+3*N-1, prefer N*N+2*N+(N-1)*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IRWORK = IE + N
C
C                 Perform bidiagonal QR iteration, computing left
C                 singular vectors of R in WORK(IR) and computing right
C                 singular vectors of R in VT
C                 (CWorkspace: need N*N)
C                 (RWorkspace: need BDSPAC)
C
                  CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
     $                         LDVT, WORK( IR ), LDWRKR, CDUM, 1,
     $                         RWORK( IRWORK ), INFO )
                  IU = ITAUQ
C
C                 Multiply Q in A by left singular vectors of R in
C                 WORK(IR), storing result in WORK(IU) and copying to A
C                 (CWorkspace: need N*N+N, prefer N*N+M*N)
C                 (RWorkspace: 0)
C
                  DO 20 I = 1, M, LDWRKU
                     CHUNK = MIN( M-I+1, LDWRKU )
                     CALL YGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
     $                           LDA, WORK( IR ), LDWRKR, CZERO,
     $                           WORK( IU ), LDWRKU )
                     CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
     $                            A( I, 1 ), LDA )
   20             CONTINUE
C
               ELSE
C
C                 Insufficient workspace for a fast algorithm
C
                  ITAU = 1
                  IWORK = ITAU + N
C
C                 Compute A=Q*R
C                 (CWorkspace: need 2*N, prefer N+N*NB)
C                 (RWorkspace: 0)
C
                  CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Copy R to VT, zeroing out below it
C
                  CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
                  CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, VT( 2, 1 ),
     $                         LDVT )
C
C                 Generate Q in A
C                 (CWorkspace: need 2*N, prefer N+N*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IE = 1
                  ITAUQ = ITAU
                  ITAUP = ITAUQ + N
                  IWORK = ITAUP + N
C
C                 Bidiagonalize R in VT
C                 (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
C                 (RWorkspace: N)
C
                  CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Multiply Q in A by left vectors bidiagonalizing R
C                 (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
     $                         WORK( ITAUQ ), A, LDA, WORK( IWORK ),
     $                         LWORK-IWORK+1, IERR )
C
C                 Generate right vectors bidiagonalizing R in VT
C                 (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IRWORK = IE + N
C
C                 Perform bidiagonal QR iteration, computing left
C                 singular vectors of A in A and computing right
C                 singular vectors of A in VT
C                 (CWorkspace: 0)
C                 (RWorkspace: need BDSPAC)
C
                  CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
     $                         LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
     $                         INFO )
C
               END IF
C
            ELSE IF( WNTUS ) THEN
C
               IF( WNTVN ) THEN
C
C                 Path 4 (M much larger than N, JOBU='S', JOBVT='N')
C                 N left singular vectors to be computed in U and
C                 no right singular vectors to be computed
C
                  IF( LWORK.GE.N*N+3*N ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IR = 1
                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
C
C                       WORK(IR) is LDA by N
C
                        LDWRKR = LDA
                     ELSE
C
C                       WORK(IR) is N by N
C
                        LDWRKR = N
                     END IF
                     ITAU = IR + LDWRKR*N
                     IWORK = ITAU + N
C
C                    Compute A=Q*R
C                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R to WORK(IR), zeroing out below it
C
                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ),
     $                            LDWRKR )
                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                            WORK( IR+1 ), LDWRKR )
C
C                    Generate Q in A
C                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
C
C                    Bidiagonalize R in WORK(IR)
C                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
C                    (RWorkspace: need N)
C
                     CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S,
     $                            RWORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate left vectors bidiagonalizing R in WORK(IR)
C                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IRWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of R in WORK(IR)
C                    (CWorkspace: need N*N)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM,
     $                            1, WORK( IR ), LDWRKR, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
C                    Multiply Q in A by left singular vectors of R in
C                    WORK(IR), storing result in U
C                    (CWorkspace: need N*N)
C                    (RWorkspace: 0)
C
                     CALL YGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
     $                           WORK( IR ), LDWRKR, CZERO, U, LDU )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (CWorkspace: need 2*N, prefer N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (CWorkspace: need 2*N, prefer N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
C
C                    Zero out below R in A
C
                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                            A( 2, 1 ), LDA )
C
C                    Bidiagonalize R in A
C                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
C                    (RWorkspace: need N)
C
                     CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply Q in U by left vectors bidiagonalizing R
C                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IRWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U
C                    (CWorkspace: 0)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM,
     $                            1, U, LDU, CDUM, 1, RWORK( IRWORK ),
     $                            INFO )
C
                  END IF
C
               ELSE IF( WNTVO ) THEN
C
C                 Path 5 (M much larger than N, JOBU='S', JOBVT='O')
C                 N left singular vectors to be computed in U and
C                 N right singular vectors to be overwritten on A
C
                  IF( LWORK.GE.2*N*N+3*N ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
C
C                       WORK(IU) is LDA by N and WORK(IR) is LDA by N
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*N
                        LDWRKR = LDA
                     ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
C
C                       WORK(IU) is LDA by N and WORK(IR) is N by N
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*N
                        LDWRKR = N
                     ELSE
C
C                       WORK(IU) is N by N and WORK(IR) is N by N
C
                        LDWRKU = N
                        IR = IU + LDWRKU*N
                        LDWRKR = N
                     END IF
                     ITAU = IR + LDWRKR*N
                     IWORK = ITAU + N
C
C                    Compute A=Q*R
C                    (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R to WORK(IU), zeroing out below it
C
                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
     $                            LDWRKU )
                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                            WORK( IU+1 ), LDWRKU )
C
C                    Generate Q in A
C                    (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
C
C                    Bidiagonalize R in WORK(IU), copying result to
C                    WORK(IR)
C                    (CWorkspace: need   2*N*N+3*N,
C                                 prefer 2*N*N+2*N+2*N*NB)
C                    (RWorkspace: need   N)
C
                     CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
     $                            RWORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU,
     $                            WORK( IR ), LDWRKR )
C
C                    Generate left bidiagonalizing vectors in WORK(IU)
C                    (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in WORK(IR)
C                    (CWorkspace: need   2*N*N+3*N-1,
C                                 prefer 2*N*N+2*N+(N-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IRWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of R in WORK(IU) and computing
C                    right singular vectors of R in WORK(IR)
C                    (CWorkspace: need 2*N*N)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ),
     $                            WORK( IR ), LDWRKR, WORK( IU ),
     $                            LDWRKU, CDUM, 1, RWORK( IRWORK ),
     $                            INFO )
C
C                    Multiply Q in A by left singular vectors of R in
C                    WORK(IU), storing result in U
C                    (CWorkspace: need N*N)
C                    (RWorkspace: 0)
C
                     CALL YGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
     $                           WORK( IU ), LDWRKU, CZERO, U, LDU )
C
C                    Copy right singular vectors of R to A
C                    (CWorkspace: need N*N)
C                    (RWorkspace: 0)
C
                     CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
     $                            LDA )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (CWorkspace: need 2*N, prefer N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (CWorkspace: need 2*N, prefer N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
C
C                    Zero out below R in A
C
                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                            A( 2, 1 ), LDA )
C
C                    Bidiagonalize R in A
C                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
C                    (RWorkspace: need N)
C
                     CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply Q in U by left vectors bidiagonalizing R
C                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right vectors bidiagonalizing R in A
C                    (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U and computing right
C                    singular vectors of A in A
C                    (CWorkspace: 0)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A,
     $                            LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
     $                            INFO )
C
                  END IF
C
               ELSE IF( WNTVAS ) THEN
C
C                 Path 6 (M much larger than N, JOBU='S', JOBVT='S'
C                         or 'A')
C                 N left singular vectors to be computed in U and
C                 N right singular vectors to be computed in VT
C
                  IF( LWORK.GE.N*N+3*N ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
C
C                       WORK(IU) is LDA by N
C
                        LDWRKU = LDA
                     ELSE
C
C                       WORK(IU) is N by N
C
                        LDWRKU = N
                     END IF
                     ITAU = IU + LDWRKU*N
                     IWORK = ITAU + N
C
C                    Compute A=Q*R
C                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R to WORK(IU), zeroing out below it
C
                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
     $                            LDWRKU )
                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                            WORK( IU+1 ), LDWRKU )
C
C                    Generate Q in A
C                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
C
C                    Bidiagonalize R in WORK(IU), copying result to VT
C                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
C                    (RWorkspace: need N)
C
                     CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
     $                            RWORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
     $                            LDVT )
C
C                    Generate left bidiagonalizing vectors in WORK(IU)
C                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in VT
C                    (CWorkspace: need   N*N+3*N-1,
C                                 prefer N*N+2*N+(N-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of R in WORK(IU) and computing
C                    right singular vectors of R in VT
C                    (CWorkspace: need N*N)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
     $                            LDVT, WORK( IU ), LDWRKU, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
C                    Multiply Q in A by left singular vectors of R in
C                    WORK(IU), storing result in U
C                    (CWorkspace: need N*N)
C                    (RWorkspace: 0)
C
                     CALL YGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
     $                           WORK( IU ), LDWRKU, CZERO, U, LDU )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (CWorkspace: need 2*N, prefer N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (CWorkspace: need 2*N, prefer N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R to VT, zeroing out below it
C
                     CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                            VT( 2, 1 ), LDVT )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
C
C                    Bidiagonalize R in VT
C                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
C                    (RWorkspace: need N)
C
                     CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply Q in U by left bidiagonalizing vectors
C                    in VT
C                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in VT
C                    (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U and computing right
C                    singular vectors of A in VT
C                    (CWorkspace: 0)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
     $                            LDVT, U, LDU, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
                  END IF
C
               END IF
C
            ELSE IF( WNTUA ) THEN
C
               IF( WNTVN ) THEN
C
C                 Path 7 (M much larger than N, JOBU='A', JOBVT='N')
C                 M left singular vectors to be computed in U and
C                 no right singular vectors to be computed
C
                  IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IR = 1
                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
C
C                       WORK(IR) is LDA by N
C
                        LDWRKR = LDA
                     ELSE
C
C                       WORK(IR) is N by N
C
                        LDWRKR = N
                     END IF
                     ITAU = IR + LDWRKR*N
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Copy R to WORK(IR), zeroing out below it
C
                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ),
     $                            LDWRKR )
                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                            WORK( IR+1 ), LDWRKR )
C
C                    Generate Q in U
C                    (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
C
C                    Bidiagonalize R in WORK(IR)
C                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
C                    (RWorkspace: need N)
C
                     CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S,
     $                            RWORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in WORK(IR)
C                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IRWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of R in WORK(IR)
C                    (CWorkspace: need N*N)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM,
     $                            1, WORK( IR ), LDWRKR, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
C                    Multiply Q in U by left singular vectors of R in
C                    WORK(IR), storing result in A
C                    (CWorkspace: need N*N)
C                    (RWorkspace: 0)
C
                     CALL YGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
     $                           WORK( IR ), LDWRKR, CZERO, A, LDA )
C
C                    Copy left singular vectors of A from A to U
C
                     CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (CWorkspace: need 2*N, prefer N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (CWorkspace: need N+M, prefer N+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
C
C                    Zero out below R in A
C
                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                            A( 2, 1 ), LDA )
C
C                    Bidiagonalize R in A
C                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
C                    (RWorkspace: need N)
C
                     CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply Q in U by left bidiagonalizing vectors
C                    in A
C                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IRWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U
C                    (CWorkspace: 0)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM,
     $                            1, U, LDU, CDUM, 1, RWORK( IRWORK ),
     $                            INFO )
C
                  END IF
C
               ELSE IF( WNTVO ) THEN
C
C                 Path 8 (M much larger than N, JOBU='A', JOBVT='O')
C                 M left singular vectors to be computed in U and
C                 N right singular vectors to be overwritten on A
C
                  IF( LWORK.GE.2*N*N+MAX( N+M, 3*N ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
C
C                       WORK(IU) is LDA by N and WORK(IR) is LDA by N
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*N
                        LDWRKR = LDA
                     ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
C
C                       WORK(IU) is LDA by N and WORK(IR) is N by N
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*N
                        LDWRKR = N
                     ELSE
C
C                       WORK(IU) is N by N and WORK(IR) is N by N
C
                        LDWRKU = N
                        IR = IU + LDWRKU*N
                        LDWRKR = N
                     END IF
                     ITAU = IR + LDWRKR*N
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (CWorkspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R to WORK(IU), zeroing out below it
C
                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
     $                            LDWRKU )
                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                            WORK( IU+1 ), LDWRKU )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
C
C                    Bidiagonalize R in WORK(IU), copying result to
C                    WORK(IR)
C                    (CWorkspace: need   2*N*N+3*N,
C                                 prefer 2*N*N+2*N+2*N*NB)
C                    (RWorkspace: need   N)
C
                     CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
     $                            RWORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU,
     $                            WORK( IR ), LDWRKR )
C
C                    Generate left bidiagonalizing vectors in WORK(IU)
C                    (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in WORK(IR)
C                    (CWorkspace: need   2*N*N+3*N-1,
C                                 prefer 2*N*N+2*N+(N-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IRWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of R in WORK(IU) and computing
C                    right singular vectors of R in WORK(IR)
C                    (CWorkspace: need 2*N*N)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ),
     $                            WORK( IR ), LDWRKR, WORK( IU ),
     $                            LDWRKU, CDUM, 1, RWORK( IRWORK ),
     $                            INFO )
C
C                    Multiply Q in U by left singular vectors of R in
C                    WORK(IU), storing result in A
C                    (CWorkspace: need N*N)
C                    (RWorkspace: 0)
C
                     CALL YGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
     $                           WORK( IU ), LDWRKU, CZERO, A, LDA )
C
C                    Copy left singular vectors of A from A to U
C
                     CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
C
C                    Copy right singular vectors of R from WORK(IR) to A
C
                     CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
     $                            LDA )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (CWorkspace: need 2*N, prefer N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (CWorkspace: need N+M, prefer N+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
C
C                    Zero out below R in A
C
                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                            A( 2, 1 ), LDA )
C
C                    Bidiagonalize R in A
C                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
C                    (RWorkspace: need N)
C
                     CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply Q in U by left bidiagonalizing vectors
C                    in A
C                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in A
C                    (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U and computing right
C                    singular vectors of A in A
C                    (CWorkspace: 0)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A,
     $                            LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
     $                            INFO )
C
                  END IF
C
               ELSE IF( WNTVAS ) THEN
C
C                 Path 9 (M much larger than N, JOBU='A', JOBVT='S'
C                         or 'A')
C                 M left singular vectors to be computed in U and
C                 N right singular vectors to be computed in VT
C
                  IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
C
C                       WORK(IU) is LDA by N
C
                        LDWRKU = LDA
                     ELSE
C
C                       WORK(IU) is N by N
C
                        LDWRKU = N
                     END IF
                     ITAU = IU + LDWRKU*N
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R to WORK(IU), zeroing out below it
C
                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
     $                            LDWRKU )
                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                            WORK( IU+1 ), LDWRKU )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
C
C                    Bidiagonalize R in WORK(IU), copying result to VT
C                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
C                    (RWorkspace: need N)
C
                     CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
     $                            RWORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
     $                            LDVT )
C
C                    Generate left bidiagonalizing vectors in WORK(IU)
C                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in VT
C                    (CWorkspace: need   N*N+3*N-1,
C                                 prefer N*N+2*N+(N-1)*NB)
C                    (RWorkspace: need   0)
C
                     CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of R in WORK(IU) and computing
C                    right singular vectors of R in VT
C                    (CWorkspace: need N*N)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
     $                            LDVT, WORK( IU ), LDWRKU, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
C                    Multiply Q in U by left singular vectors of R in
C                    WORK(IU), storing result in A
C                    (CWorkspace: need N*N)
C                    (RWorkspace: 0)
C
                     CALL YGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
     $                           WORK( IU ), LDWRKU, CZERO, A, LDA )
C
C                    Copy left singular vectors of A from A to U
C
                     CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + N
C
C                    Compute A=Q*R, copying result to U
C                    (CWorkspace: need 2*N, prefer N+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
C
C                    Generate Q in U
C                    (CWorkspace: need N+M, prefer N+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy R from A to VT, zeroing out below it
C
                     CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                            VT( 2, 1 ), LDVT )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
C
C                    Bidiagonalize R in VT
C                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
C                    (RWorkspace: need N)
C
                     CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply Q in U by left bidiagonalizing vectors
C                    in VT
C                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in VT
C                    (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + N
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U and computing right
C                    singular vectors of A in VT
C                    (CWorkspace: 0)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
     $                            LDVT, U, LDU, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
                  END IF
C
               END IF
C
            END IF
C
         ELSE
C
C           M .LT. MNTHR
C
C           Path 10 (M at least N, but not much larger)
C           Reduce to bidiagonal form without QR decomposition
C
            IE = 1
            ITAUQ = 1
            ITAUP = ITAUQ + N
            IWORK = ITAUP + N
C
C           Bidiagonalize A
C           (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
C           (RWorkspace: need N)
C
            CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
     $                   WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
     $                   IERR )
            IF( WNTUAS ) THEN
C
C              If left singular vectors desired in U, copy result to U
C              and generate left bidiagonalizing vectors in U
C              (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB)
C              (RWorkspace: 0)
C
               CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
               IF( WNTUS )
     $            NCU = N
               IF( WNTUA )
     $            NCU = M
               CALL ZUNGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ),
     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTVAS ) THEN
C
C              If right singular vectors desired in VT, copy result to
C              VT and generate right bidiagonalizing vectors in VT
C              (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
C              (RWorkspace: 0)
C
               CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
               CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTUO ) THEN
C
C              If left singular vectors desired in A, generate left
C              bidiagonalizing vectors in A
C              (CWorkspace: need 3*N, prefer 2*N+N*NB)
C              (RWorkspace: 0)
C
               CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTVO ) THEN
C
C              If right singular vectors desired in A, generate right
C              bidiagonalizing vectors in A
C              (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
C              (RWorkspace: 0)
C
               CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IRWORK = 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
C
C              Perform bidiagonal QR iteration, if desired, computing
C              left singular vectors in U and computing right singular
C              vectors in VT
C              (CWorkspace: 0)
C              (RWorkspace: need BDSPAC)
C
               CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT,
     $                      LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ),
     $                      INFO )
            ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
C
C              Perform bidiagonal QR iteration, if desired, computing
C              left singular vectors in U and computing right singular
C              vectors in A
C              (CWorkspace: 0)
C              (RWorkspace: need BDSPAC)
C
               CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), A,
     $                      LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
     $                      INFO )
            ELSE
C
C              Perform bidiagonal QR iteration, if desired, computing
C              left singular vectors in A and computing right singular
C              vectors in VT
C              (CWorkspace: 0)
C              (RWorkspace: need BDSPAC)
C
               CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT,
     $                      LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
     $                      INFO )
            END IF
C
         END IF
C
      ELSE
C
C        A has more columns than rows. If A has sufficiently more
C        columns than rows, first reduce using the LQ decomposition (if
C        sufficient workspace available)
C
         IF( N.GE.MNTHR ) THEN
C
            IF( WNTVN ) THEN
C
C              Path 1t(N much larger than M, JOBVT='N')
C              No right singular vectors to be computed
C
               ITAU = 1
               IWORK = ITAU + M
C
C              Compute A=L*Q
C              (CWorkspace: need 2*M, prefer M+M*NB)
C              (RWorkspace: 0)
C
               CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
     $                      LWORK-IWORK+1, IERR )
C
C              Zero out above L
C
               CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ),
     $                      LDA )
               IE = 1
               ITAUQ = 1
               ITAUP = ITAUQ + M
               IWORK = ITAUP + M
C
C              Bidiagonalize L in A
C              (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
C              (RWorkspace: need M)
C
               CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
     $                      WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
     $                      IERR )
               IF( WNTUO .OR. WNTUAS ) THEN
C
C                 If left singular vectors desired, generate Q
C                 (CWorkspace: need 3*M, prefer 2*M+M*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
               END IF
               IRWORK = IE + M
               NRU = 0
               IF( WNTUO .OR. WNTUAS )
     $            NRU = M
C
C              Perform bidiagonal QR iteration, computing left singular
C              vectors of A in A if desired
C              (CWorkspace: 0)
C              (RWorkspace: need BDSPAC)
C
               CALL ZBDSQR( 'U', M, 0, NRU, 0, S, RWORK( IE ), CDUM, 1,
     $                      A, LDA, CDUM, 1, RWORK( IRWORK ), INFO )
C
C              If left singular vectors desired in U, copy them there
C
               IF( WNTUAS )
     $            CALL ZLACPY( 'F', M, M, A, LDA, U, LDU )
C
            ELSE IF( WNTVO .AND. WNTUN ) THEN
C
C              Path 2t(N much larger than M, JOBU='N', JOBVT='O')
C              M right singular vectors to be overwritten on A and
C              no left singular vectors to be computed
C
               IF( LWORK.GE.M*M+3*M ) THEN
C
C                 Sufficient workspace for a fast algorithm
C
                  IR = 1
                  IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN
C
C                    WORK(IU) is LDA by N and WORK(IR) is LDA by M
C
                     LDWRKU = LDA
                     CHUNK = N
                     LDWRKR = LDA
                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN
C
C                    WORK(IU) is LDA by N and WORK(IR) is M by M
C
                     LDWRKU = LDA
                     CHUNK = N
                     LDWRKR = M
                  ELSE
C
C                    WORK(IU) is M by CHUNK and WORK(IR) is M by M
C
                     LDWRKU = M
                     CHUNK = ( LWORK-M*M ) / M
                     LDWRKR = M
                  END IF
                  ITAU = IR + LDWRKR*M
                  IWORK = ITAU + M
C
C                 Compute A=L*Q
C                 (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
C                 (RWorkspace: 0)
C
                  CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Copy L to WORK(IR) and zero out above it
C
                  CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
                  CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                         WORK( IR+LDWRKR ), LDWRKR )
C
C                 Generate Q in A
C                 (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IE = 1
                  ITAUQ = ITAU
                  ITAUP = ITAUQ + M
                  IWORK = ITAUP + M
C
C                 Bidiagonalize L in WORK(IR)
C                 (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
C                 (RWorkspace: need M)
C
                  CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, RWORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Generate right vectors bidiagonalizing L
C                 (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
     $                         WORK( ITAUP ), WORK( IWORK ),
     $                         LWORK-IWORK+1, IERR )
                  IRWORK = IE + M
C
C                 Perform bidiagonal QR iteration, computing right
C                 singular vectors of L in WORK(IR)
C                 (CWorkspace: need M*M)
C                 (RWorkspace: need BDSPAC)
C
                  CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
     $                         WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
     $                         RWORK( IRWORK ), INFO )
                  IU = ITAUQ
C
C                 Multiply right singular vectors of L in WORK(IR) by Q
C                 in A, storing result in WORK(IU) and copying to A
C                 (CWorkspace: need M*M+M, prefer M*M+M*N)
C                 (RWorkspace: 0)
C
                  DO 30 I = 1, N, CHUNK
                     BLK = MIN( N-I+1, CHUNK )
                     CALL YGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
     $                           LDWRKR, A( 1, I ), LDA, CZERO,
     $                           WORK( IU ), LDWRKU )
                     CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
     $                            A( 1, I ), LDA )
   30             CONTINUE
C
               ELSE
C
C                 Insufficient workspace for a fast algorithm
C
                  IE = 1
                  ITAUQ = 1
                  ITAUP = ITAUQ + M
                  IWORK = ITAUP + M
C
C                 Bidiagonalize A
C                 (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
C                 (RWorkspace: need M)
C
                  CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Generate right vectors bidiagonalizing A
C                 (CWorkspace: need 3*M, prefer 2*M+M*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IRWORK = IE + M
C
C                 Perform bidiagonal QR iteration, computing right
C                 singular vectors of A in A
C                 (CWorkspace: 0)
C                 (RWorkspace: need BDSPAC)
C
                  CALL ZBDSQR( 'L', M, N, 0, 0, S, RWORK( IE ), A, LDA,
     $                         CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO )
C
               END IF
C
            ELSE IF( WNTVO .AND. WNTUAS ) THEN
C
C              Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
C              M right singular vectors to be overwritten on A and
C              M left singular vectors to be computed in U
C
               IF( LWORK.GE.M*M+3*M ) THEN
C
C                 Sufficient workspace for a fast algorithm
C
                  IR = 1
                  IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN
C
C                    WORK(IU) is LDA by N and WORK(IR) is LDA by M
C
                     LDWRKU = LDA
                     CHUNK = N
                     LDWRKR = LDA
                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN
C
C                    WORK(IU) is LDA by N and WORK(IR) is M by M
C
                     LDWRKU = LDA
                     CHUNK = N
                     LDWRKR = M
                  ELSE
C
C                    WORK(IU) is M by CHUNK and WORK(IR) is M by M
C
                     LDWRKU = M
                     CHUNK = ( LWORK-M*M ) / M
                     LDWRKR = M
                  END IF
                  ITAU = IR + LDWRKR*M
                  IWORK = ITAU + M
C
C                 Compute A=L*Q
C                 (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
C                 (RWorkspace: 0)
C
                  CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Copy L to U, zeroing about above it
C
                  CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
                  CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ),
     $                         LDU )
C
C                 Generate Q in A
C                 (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IE = 1
                  ITAUQ = ITAU
                  ITAUP = ITAUQ + M
                  IWORK = ITAUP + M
C
C                 Bidiagonalize L in U, copying result to WORK(IR)
C                 (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
C                 (RWorkspace: need M)
C
                  CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  CALL ZLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
C
C                 Generate right vectors bidiagonalizing L in WORK(IR)
C                 (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
     $                         WORK( ITAUP ), WORK( IWORK ),
     $                         LWORK-IWORK+1, IERR )
C
C                 Generate left vectors bidiagonalizing L in U
C                 (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IRWORK = IE + M
C
C                 Perform bidiagonal QR iteration, computing left
C                 singular vectors of L in U, and computing right
C                 singular vectors of L in WORK(IR)
C                 (CWorkspace: need M*M)
C                 (RWorkspace: need BDSPAC)
C
                  CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
     $                         WORK( IR ), LDWRKR, U, LDU, CDUM, 1,
     $                         RWORK( IRWORK ), INFO )
                  IU = ITAUQ
C
C                 Multiply right singular vectors of L in WORK(IR) by Q
C                 in A, storing result in WORK(IU) and copying to A
C                 (CWorkspace: need M*M+M, prefer M*M+M*N))
C                 (RWorkspace: 0)
C
                  DO 40 I = 1, N, CHUNK
                     BLK = MIN( N-I+1, CHUNK )
                     CALL YGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
     $                           LDWRKR, A( 1, I ), LDA, CZERO,
     $                           WORK( IU ), LDWRKU )
                     CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
     $                            A( 1, I ), LDA )
   40             CONTINUE
C
               ELSE
C
C                 Insufficient workspace for a fast algorithm
C
                  ITAU = 1
                  IWORK = ITAU + M
C
C                 Compute A=L*Q
C                 (CWorkspace: need 2*M, prefer M+M*NB)
C                 (RWorkspace: 0)
C
                  CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Copy L to U, zeroing out above it
C
                  CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
                  CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ),
     $                         LDU )
C
C                 Generate Q in A
C                 (CWorkspace: need 2*M, prefer M+M*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IE = 1
                  ITAUQ = ITAU
                  ITAUP = ITAUQ + M
                  IWORK = ITAUP + M
C
C                 Bidiagonalize L in U
C                 (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
C                 (RWorkspace: need M)
C
                  CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
     $                         WORK( ITAUQ ), WORK( ITAUP ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                 Multiply right vectors bidiagonalizing L by Q in A
C                 (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
     $                         WORK( ITAUP ), A, LDA, WORK( IWORK ),
     $                         LWORK-IWORK+1, IERR )
C
C                 Generate left vectors bidiagonalizing L in U
C                 (CWorkspace: need 3*M, prefer 2*M+M*NB)
C                 (RWorkspace: 0)
C
                  CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IRWORK = IE + M
C
C                 Perform bidiagonal QR iteration, computing left
C                 singular vectors of A in U and computing right
C                 singular vectors of A in A
C                 (CWorkspace: 0)
C                 (RWorkspace: need BDSPAC)
C
                  CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), A, LDA,
     $                         U, LDU, CDUM, 1, RWORK( IRWORK ), INFO )
C
               END IF
C
            ELSE IF( WNTVS ) THEN
C
               IF( WNTUN ) THEN
C
C                 Path 4t(N much larger than M, JOBU='N', JOBVT='S')
C                 M right singular vectors to be computed in VT and
C                 no left singular vectors to be computed
C
                  IF( LWORK.GE.M*M+3*M ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IR = 1
                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
C
C                       WORK(IR) is LDA by M
C
                        LDWRKR = LDA
                     ELSE
C
C                       WORK(IR) is M by M
C
                        LDWRKR = M
                     END IF
                     ITAU = IR + LDWRKR*M
                     IWORK = ITAU + M
C
C                    Compute A=L*Q
C                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to WORK(IR), zeroing out above it
C
                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ),
     $                            LDWRKR )
                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                            WORK( IR+LDWRKR ), LDWRKR )
C
C                    Generate Q in A
C                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
C
C                    Bidiagonalize L in WORK(IR)
C                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
C                    (RWorkspace: need M)
C
                     CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S,
     $                            RWORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right vectors bidiagonalizing L in
C                    WORK(IR)
C                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IRWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing right
C                    singular vectors of L in WORK(IR)
C                    (CWorkspace: need M*M)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
     $                            WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
C                    Multiply right singular vectors of L in WORK(IR) by
C                    Q in A, storing result in VT
C                    (CWorkspace: need M*M)
C                    (RWorkspace: 0)
C
                     CALL YGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ),
     $                           LDWRKR, A, LDA, CZERO, VT, LDVT )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + M
C
C                    Compute A=L*Q
C                    (CWorkspace: need 2*M, prefer M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy result to VT
C
                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (CWorkspace: need 2*M, prefer M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
C
C                    Zero out above L in A
C
                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                            A( 1, 2 ), LDA )
C
C                    Bidiagonalize L in A
C                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
C                    (RWorkspace: need M)
C
                     CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply right vectors bidiagonalizing L by Q in VT
C                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
     $                            WORK( ITAUP ), VT, LDVT,
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing right
C                    singular vectors of A in VT
C                    (CWorkspace: 0)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT,
     $                            LDVT, CDUM, 1, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
                  END IF
C
               ELSE IF( WNTUO ) THEN
C
C                 Path 5t(N much larger than M, JOBU='O', JOBVT='S')
C                 M right singular vectors to be computed in VT and
C                 M left singular vectors to be overwritten on A
C
                  IF( LWORK.GE.2*M*M+3*M ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
C
C                       WORK(IU) is LDA by M and WORK(IR) is LDA by M
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*M
                        LDWRKR = LDA
                     ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
C
C                       WORK(IU) is LDA by M and WORK(IR) is M by M
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*M
                        LDWRKR = M
                     ELSE
C
C                       WORK(IU) is M by M and WORK(IR) is M by M
C
                        LDWRKU = M
                        IR = IU + LDWRKU*M
                        LDWRKR = M
                     END IF
                     ITAU = IR + LDWRKR*M
                     IWORK = ITAU + M
C
C                    Compute A=L*Q
C                    (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to WORK(IU), zeroing out below it
C
                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
     $                            LDWRKU )
                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                            WORK( IU+LDWRKU ), LDWRKU )
C
C                    Generate Q in A
C                    (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
C
C                    Bidiagonalize L in WORK(IU), copying result to
C                    WORK(IR)
C                    (CWorkspace: need   2*M*M+3*M,
C                                 prefer 2*M*M+2*M+2*M*NB)
C                    (RWorkspace: need   M)
C
                     CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
     $                            RWORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU,
     $                            WORK( IR ), LDWRKR )
C
C                    Generate right bidiagonalizing vectors in WORK(IU)
C                    (CWorkspace: need   2*M*M+3*M-1,
C                                 prefer 2*M*M+2*M+(M-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in WORK(IR)
C                    (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IRWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of L in WORK(IR) and computing
C                    right singular vectors of L in WORK(IU)
C                    (CWorkspace: need 2*M*M)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
     $                            WORK( IU ), LDWRKU, WORK( IR ),
     $                            LDWRKR, CDUM, 1, RWORK( IRWORK ),
     $                            INFO )
C
C                    Multiply right singular vectors of L in WORK(IU) by
C                    Q in A, storing result in VT
C                    (CWorkspace: need M*M)
C                    (RWorkspace: 0)
C
                     CALL YGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
     $                           LDWRKU, A, LDA, CZERO, VT, LDVT )
C
C                    Copy left singular vectors of L to A
C                    (CWorkspace: need M*M)
C                    (RWorkspace: 0)
C
                     CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
     $                            LDA )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (CWorkspace: need 2*M, prefer M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (CWorkspace: need 2*M, prefer M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
C
C                    Zero out above L in A
C
                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                            A( 1, 2 ), LDA )
C
C                    Bidiagonalize L in A
C                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
C                    (RWorkspace: need M)
C
                     CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply right vectors bidiagonalizing L by Q in VT
C                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
     $                            WORK( ITAUP ), VT, LDVT,
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors of L in A
C                    (CWorkspace: need 3*M, prefer 2*M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in A and computing right
C                    singular vectors of A in VT
C                    (CWorkspace: 0)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
     $                            LDVT, A, LDA, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
                  END IF
C
               ELSE IF( WNTUAS ) THEN
C
C                 Path 6t(N much larger than M, JOBU='S' or 'A',
C                         JOBVT='S')
C                 M right singular vectors to be computed in VT and
C                 M left singular vectors to be computed in U
C
                  IF( LWORK.GE.M*M+3*M ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
C
C                       WORK(IU) is LDA by N
C
                        LDWRKU = LDA
                     ELSE
C
C                       WORK(IU) is LDA by M
C
                        LDWRKU = M
                     END IF
                     ITAU = IU + LDWRKU*M
                     IWORK = ITAU + M
C
C                    Compute A=L*Q
C                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to WORK(IU), zeroing out above it
C
                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
     $                            LDWRKU )
                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                            WORK( IU+LDWRKU ), LDWRKU )
C
C                    Generate Q in A
C                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
C
C                    Bidiagonalize L in WORK(IU), copying result to U
C                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
C                    (RWorkspace: need M)
C
                     CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
     $                            RWORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
     $                            LDU )
C
C                    Generate right bidiagonalizing vectors in WORK(IU)
C                    (CWorkspace: need   M*M+3*M-1,
C                                 prefer M*M+2*M+(M-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in U
C                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of L in U and computing right
C                    singular vectors of L in WORK(IU)
C                    (CWorkspace: need M*M)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
     $                            WORK( IU ), LDWRKU, U, LDU, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
C                    Multiply right singular vectors of L in WORK(IU) by
C                    Q in A, storing result in VT
C                    (CWorkspace: need M*M)
C                    (RWorkspace: 0)
C
                     CALL YGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
     $                           LDWRKU, A, LDA, CZERO, VT, LDVT )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (CWorkspace: need 2*M, prefer M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (CWorkspace: need 2*M, prefer M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to U, zeroing out above it
C
                     CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                            U( 1, 2 ), LDU )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
C
C                    Bidiagonalize L in U
C                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
C                    (RWorkspace: need M)
C
                     CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply right bidiagonalizing vectors in U by Q
C                    in VT
C                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
     $                            WORK( ITAUP ), VT, LDVT,
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in U
C                    (CWorkspace: need 3*M, prefer 2*M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U and computing right
C                    singular vectors of A in VT
C                    (CWorkspace: 0)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
     $                            LDVT, U, LDU, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
                  END IF
C
               END IF
C
            ELSE IF( WNTVA ) THEN
C
               IF( WNTUN ) THEN
C
C                 Path 7t(N much larger than M, JOBU='N', JOBVT='A')
C                 N right singular vectors to be computed in VT and
C                 no left singular vectors to be computed
C
                  IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IR = 1
                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
C
C                       WORK(IR) is LDA by M
C
                        LDWRKR = LDA
                     ELSE
C
C                       WORK(IR) is M by M
C
                        LDWRKR = M
                     END IF
                     ITAU = IR + LDWRKR*M
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Copy L to WORK(IR), zeroing out above it
C
                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ),
     $                            LDWRKR )
                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                            WORK( IR+LDWRKR ), LDWRKR )
C
C                    Generate Q in VT
C                    (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
C
C                    Bidiagonalize L in WORK(IR)
C                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
C                    (RWorkspace: need M)
C
                     CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S,
     $                            RWORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate right bidiagonalizing vectors in WORK(IR)
C                    (CWorkspace: need   M*M+3*M-1,
C                                 prefer M*M+2*M+(M-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IRWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing right
C                    singular vectors of L in WORK(IR)
C                    (CWorkspace: need M*M)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
     $                            WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
C                    Multiply right singular vectors of L in WORK(IR) by
C                    Q in VT, storing result in A
C                    (CWorkspace: need M*M)
C                    (RWorkspace: 0)
C
                     CALL YGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ),
     $                           LDWRKR, VT, LDVT, CZERO, A, LDA )
C
C                    Copy right singular vectors of A from A to VT
C
                     CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (CWorkspace: need 2*M, prefer M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (CWorkspace: need M+N, prefer M+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
C
C                    Zero out above L in A
C
                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                            A( 1, 2 ), LDA )
C
C                    Bidiagonalize L in A
C                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
C                    (RWorkspace: need M)
C
                     CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply right bidiagonalizing vectors in A by Q
C                    in VT
C                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
     $                            WORK( ITAUP ), VT, LDVT,
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing right
C                    singular vectors of A in VT
C                    (CWorkspace: 0)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT,
     $                            LDVT, CDUM, 1, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
                  END IF
C
               ELSE IF( WNTUO ) THEN
C
C                 Path 8t(N much larger than M, JOBU='O', JOBVT='A')
C                 N right singular vectors to be computed in VT and
C                 M left singular vectors to be overwritten on A
C
                  IF( LWORK.GE.2*M*M+MAX( N+M, 3*M ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
C
C                       WORK(IU) is LDA by M and WORK(IR) is LDA by M
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*M
                        LDWRKR = LDA
                     ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
C
C                       WORK(IU) is LDA by M and WORK(IR) is M by M
C
                        LDWRKU = LDA
                        IR = IU + LDWRKU*M
                        LDWRKR = M
                     ELSE
C
C                       WORK(IU) is M by M and WORK(IR) is M by M
C
                        LDWRKU = M
                        IR = IU + LDWRKU*M
                        LDWRKR = M
                     END IF
                     ITAU = IR + LDWRKR*M
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (CWorkspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to WORK(IU), zeroing out above it
C
                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
     $                            LDWRKU )
                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                            WORK( IU+LDWRKU ), LDWRKU )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
C
C                    Bidiagonalize L in WORK(IU), copying result to
C                    WORK(IR)
C                    (CWorkspace: need   2*M*M+3*M,
C                                 prefer 2*M*M+2*M+2*M*NB)
C                    (RWorkspace: need   M)
C
                     CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
     $                            RWORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU,
     $                            WORK( IR ), LDWRKR )
C
C                    Generate right bidiagonalizing vectors in WORK(IU)
C                    (CWorkspace: need   2*M*M+3*M-1,
C                                 prefer 2*M*M+2*M+(M-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in WORK(IR)
C                    (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
     $                            WORK( ITAUQ ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     IRWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of L in WORK(IR) and computing
C                    right singular vectors of L in WORK(IU)
C                    (CWorkspace: need 2*M*M)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
     $                            WORK( IU ), LDWRKU, WORK( IR ),
     $                            LDWRKR, CDUM, 1, RWORK( IRWORK ),
     $                            INFO )
C
C                    Multiply right singular vectors of L in WORK(IU) by
C                    Q in VT, storing result in A
C                    (CWorkspace: need M*M)
C                    (RWorkspace: 0)
C
                     CALL YGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
     $                           LDWRKU, VT, LDVT, CZERO, A, LDA )
C
C                    Copy right singular vectors of A from A to VT
C
                     CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
C
C                    Copy left singular vectors of A from WORK(IR) to A
C
                     CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
     $                            LDA )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (CWorkspace: need 2*M, prefer M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (CWorkspace: need M+N, prefer M+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
C
C                    Zero out above L in A
C
                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                            A( 1, 2 ), LDA )
C
C                    Bidiagonalize L in A
C                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
C                    (RWorkspace: need M)
C
                     CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply right bidiagonalizing vectors in A by Q
C                    in VT
C                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
     $                            WORK( ITAUP ), VT, LDVT,
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in A
C                    (CWorkspace: need 3*M, prefer 2*M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in A and computing right
C                    singular vectors of A in VT
C                    (CWorkspace: 0)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
     $                            LDVT, A, LDA, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
                  END IF
C
               ELSE IF( WNTUAS ) THEN
C
C                 Path 9t(N much larger than M, JOBU='S' or 'A',
C                         JOBVT='A')
C                 N right singular vectors to be computed in VT and
C                 M left singular vectors to be computed in U
C
                  IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN
C
C                    Sufficient workspace for a fast algorithm
C
                     IU = 1
                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
C
C                       WORK(IU) is LDA by M
C
                        LDWRKU = LDA
                     ELSE
C
C                       WORK(IU) is M by M
C
                        LDWRKU = M
                     END IF
                     ITAU = IU + LDWRKU*M
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to WORK(IU), zeroing out above it
C
                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
     $                            LDWRKU )
                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                            WORK( IU+LDWRKU ), LDWRKU )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
C
C                    Bidiagonalize L in WORK(IU), copying result to U
C                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
C                    (RWorkspace: need M)
C
                     CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
     $                            RWORK( IE ), WORK( ITAUQ ),
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
     $                            LDU )
C
C                    Generate right bidiagonalizing vectors in WORK(IU)
C                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
     $                            WORK( ITAUP ), WORK( IWORK ),
     $                            LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in U
C                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of L in U and computing right
C                    singular vectors of L in WORK(IU)
C                    (CWorkspace: need M*M)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
     $                            WORK( IU ), LDWRKU, U, LDU, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
C                    Multiply right singular vectors of L in WORK(IU) by
C                    Q in VT, storing result in A
C                    (CWorkspace: need M*M)
C                    (RWorkspace: 0)
C
                     CALL YGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
     $                           LDWRKU, VT, LDVT, CZERO, A, LDA )
C
C                    Copy right singular vectors of A from A to VT
C
                     CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
C
                  ELSE
C
C                    Insufficient workspace for a fast algorithm
C
                     ITAU = 1
                     IWORK = ITAU + M
C
C                    Compute A=L*Q, copying result to VT
C                    (CWorkspace: need 2*M, prefer M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
C
C                    Generate Q in VT
C                    (CWorkspace: need M+N, prefer M+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Copy L to U, zeroing out above it
C
                     CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                            U( 1, 2 ), LDU )
                     IE = 1
                     ITAUQ = ITAU
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
C
C                    Bidiagonalize L in U
C                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
C                    (RWorkspace: need M)
C
                     CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
     $                            WORK( ITAUQ ), WORK( ITAUP ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Multiply right bidiagonalizing vectors in U by Q
C                    in VT
C                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
     $                            WORK( ITAUP ), VT, LDVT,
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
C
C                    Generate left bidiagonalizing vectors in U
C                    (CWorkspace: need 3*M, prefer 2*M+M*NB)
C                    (RWorkspace: 0)
C
                     CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IRWORK = IE + M
C
C                    Perform bidiagonal QR iteration, computing left
C                    singular vectors of A in U and computing right
C                    singular vectors of A in VT
C                    (CWorkspace: 0)
C                    (RWorkspace: need BDSPAC)
C
                     CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
     $                            LDVT, U, LDU, CDUM, 1,
     $                            RWORK( IRWORK ), INFO )
C
                  END IF
C
               END IF
C
            END IF
C
         ELSE
C
C           N .LT. MNTHR
C
C           Path 10t(N greater than M, but not much larger)
C           Reduce to bidiagonal form without LQ decomposition
C
            IE = 1
            ITAUQ = 1
            ITAUP = ITAUQ + M
            IWORK = ITAUP + M
C
C           Bidiagonalize A
C           (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
C           (RWorkspace: M)
C
            CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
     $                   WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
     $                   IERR )
            IF( WNTUAS ) THEN
C
C              If left singular vectors desired in U, copy result to U
C              and generate left bidiagonalizing vectors in U
C              (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
C              (RWorkspace: 0)
C
               CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
               CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTVAS ) THEN
C
C              If right singular vectors desired in VT, copy result to
C              VT and generate right bidiagonalizing vectors in VT
C              (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB)
C              (RWorkspace: 0)
C
               CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
               IF( WNTVA )
     $            NRVT = N
               IF( WNTVS )
     $            NRVT = M
               CALL ZUNGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ),
     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTUO ) THEN
C
C              If left singular vectors desired in A, generate left
C              bidiagonalizing vectors in A
C              (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
C              (RWorkspace: 0)
C
               CALL ZUNGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTVO ) THEN
C
C              If right singular vectors desired in A, generate right
C              bidiagonalizing vectors in A
C              (CWorkspace: need 3*M, prefer 2*M+M*NB)
C              (RWorkspace: 0)
C
               CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IRWORK = 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
C
C              Perform bidiagonal QR iteration, if desired, computing
C              left singular vectors in U and computing right singular
C              vectors in VT
C              (CWorkspace: 0)
C              (RWorkspace: need BDSPAC)
C
               CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT,
     $                      LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ),
     $                      INFO )
            ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
C
C              Perform bidiagonal QR iteration, if desired, computing
C              left singular vectors in U and computing right singular
C              vectors in A
C              (CWorkspace: 0)
C              (RWorkspace: need BDSPAC)
C
               CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), A,
     $                      LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
     $                      INFO )
            ELSE
C
C              Perform bidiagonal QR iteration, if desired, computing
C              left singular vectors in A and computing right singular
C              vectors in VT
C              (CWorkspace: 0)
C              (RWorkspace: need BDSPAC)
C
               CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT,
     $                      LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
     $                      INFO )
            END IF
C
         END IF
C
      END IF
C
C     Undo scaling if necessary
C
      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,
     $                   RWORK( IE ), 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,
     $                   RWORK( IE ), MINMN, IERR )
      END IF
C
C     Return optimal workspace in WORK(1)
C
      WORK( 1 ) = MAXWRK
      Return
      End
*Deck ZHPEV
      SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK,
     $  INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK driver routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     March 31, 1993
C
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, LDZ, N
      Real*8   RWORK( * ), W( * )
      COMPLEX*16         AP( * ), WORK( * ), Z( LDZ, * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a
C  complex Hermitian matrix in packed storage.
C
C  Arguments
C  =========
C
C  JOBZ    (input) CHARACTER*1
C          = 'N':  Compute eigenvalues only;
C          = 'V':  Compute eigenvalues and eigenvectors.
C
C  UPLO    (input) CHARACTER*1
C          = 'U':  Upper triangle of A is stored;
C          = 'L':  Lower triangle of A is stored.
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
C          On entry, the upper or lower triangle of the Hermitian matrix
C          A, packed columnwise in a linear array.  The j-th column of A
C          is stored in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
C
C          On exit, AP is overwritten by values generated during the
C          reduction to tridiagonal form.  If UPLO = 'U', the diagonal
C          and first superdiagonal of the tridiagonal matrix T overwrite
C          the corresponding elements of A, and if UPLO = 'L', the
C          diagonal and first subdiagonal of T overwrite the
C          corresponding elements of A.
C
C  W       (output) DOUBLE PRECISION array, dimension (N)
C          If INFO = 0, the eigenvalues in ascending order.
C
C  Z       (output) COMPLEX*16 array, dimension (LDZ, N)
C          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
C          eigenvectors of the matrix A, with the i-th column of Z
C          holding the eigenvector associated with W(i).
C          If JOBZ = 'N', then Z is not referenced.
C
C  LDZ     (input) INTEGER
C          The leading dimension of the array Z.  LDZ >= 1, and if
C          JOBZ = 'V', LDZ >= max(1,N).
C
C  WORK    (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))
C
C  RWORK   (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))
C
C  INFO    (output) INTEGER
C          = 0:  successful exit.
C          < 0:  if INFO = -i, the i-th argument had an illegal value.
C          > 0:  if INFO = i, the algorithm failed to converge; i
C                off-diagonal elements of an intermediate tridiagonal
C                form did not converge to zero.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            WANTZ
      INTEGER            IINFO, IMAX, INDE, INDRWK, INDTAU, INDWRK,
     $                   ISCALE
      Real*8   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
     $                   SMLNUM
      Logical            GLSame
C
C     Test the input parameters.
C
#ifdef USE_ESSL_LAP
      Call GauErr('Use_ESSL_LAP set but generic ZHPEV called.')
#endif
      WANTZ = GLSame( JOBZ, 'V' )
      INFO = 0
      IF( .NOT.( WANTZ .OR. GLSame( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( GLSame( UPLO, 'L' ) .OR. GLSame( UPLO, 'U' ) ) )
     $          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) Call GLBErr('ZHPEV',Info)
      If(N.eq.0) RETURN
      IF( N.EQ.1 ) THEN
         W( 1 ) = AP( 1 )
         RWORK( 1 ) = 1
         IF( WANTZ )
     $      Z( 1, 1 ) = ONE
         RETURN
      END IF
C
C     Get machine constants.
C
      SAFMIN = SFMin
      EPS = Prec
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = SQRT( BIGNUM )
C
C     Scale matrix to allowable range, if necessary.
C
      ANRM = ZLANHP( 'M', UPLO, N, AP, RWORK )
      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 YDScal( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
      END IF
C
C     Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form.
C
      INDE = 1
      INDTAU = 1
      CALL ZHPTRD( UPLO, N, AP, W, RWORK( INDE ), WORK( INDTAU ),
     $             IINFO )
C
C     For eigenvalues only, call DSTERF.  For eigenvectors, first call
C     ZUPGTR to generate the orthogonal matrix, then call ZSTEQR.
C
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, W, RWORK( INDE ), INFO )
      ELSE
         INDWRK = INDTAU + N
         CALL ZUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
     $                WORK( INDWRK ), IINFO )
         INDRWK = INDE + N
         CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ,
     $                RWORK( INDRWK ), INFO )
      END IF
C
C     If matrix was scaled, then rescale eigenvalues appropriately.
C
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = N
         ELSE
            IMAX = INFO - 1
         END IF
         CALL GSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
      RETURN
      END
*Deck ZHPTRD
      Subroutine ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
C     ..
C     .. Array Arguments ..
      Real*8   D( * ), E( * )
      COMPLEX*16         AP( * ), TAU( * )
C     ..
C
C  Purpose
C  =======
C
C  ZHPTRD reduces a complex Hermitian matrix A stored in packed form to
C  real symmetric tridiagonal form T by a unitary similarity
C  transformation: Q**H * A * Q = T.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          = 'U':  Upper triangle of A is stored;
C          = 'L':  Lower triangle of A is stored.
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
C          On entry, the upper or lower triangle of the Hermitian matrix
C          A, packed columnwise in a linear array.  The j-th column of A
C          is stored in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
C          On exit, if UPLO = 'U', the diagonal and first superdiagonal
C          of A are overwritten by the corresponding elements of the
C          tridiagonal matrix T, and the elements above the first
C          superdiagonal, with the array TAU, represent the unitary
C          matrix Q as a product of elementary reflectors; if UPLO
C          = 'L', the diagonal and first subdiagonal of A are over-
C          written by the corresponding elements of the tridiagonal
C          matrix T, and the elements below the first subdiagonal, with
C          the array TAU, represent the unitary matrix Q as a product
C          of elementary reflectors. See Further Details.
C
C  D       (output) DOUBLE PRECISION array, dimension (N)
C          The diagonal elements of the tridiagonal matrix T:
C          D(i) = A(i,i).
C
C  E       (output) DOUBLE PRECISION array, dimension (N-1)
C          The off-diagonal elements of the tridiagonal matrix T:
C          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
C
C  TAU     (output) COMPLEX*16 array, dimension (N-1)
C          The scalar factors of the elementary reflectors (see Further
C          Details).
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  Further Details
C  ===============
C
C  If UPLO = 'U', the matrix Q is represented as a product of elementary
C  reflectors
C
C     Q = H(n-1) . . . H(2) H(1).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a complex scalar, and v is a complex vector with
C  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
C  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
C
C  If UPLO = 'L', the matrix Q is represented as a product of elementary
C  reflectors
C
C     Q = H(1) H(2) . . . H(n-1).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a complex scalar, and v is a complex vector with
C  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
C  overwriting A(i+2:n,i), and tau is stored in TAU(i).
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ONE, ZERO, HALF
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
     $                   ZERO = ( 0.0D+0, 0.0D+0 ),
     $                   HALF = ( 0.5D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER, GLSame
      INTEGER            I, I1, I1I1, II
      COMPLEX*16         ALPHA, TAUI, YDotC
C
C     Test the input parameters
C
      INFO = 0
      UPPER = GLSame( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.GLSame( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      If(Info.ne.0) Call GLBErr('ZHPTRD',Info)
      If(N.le.0) RETURN
      IF( UPPER ) THEN
C
C        Reduce the upper triangle of A.
C        I1 is the index in AP of A(1,I+1).
C
         I1 = N*( N-1 ) / 2 + 1
         AP( I1+N-1 ) = GREAL( AP( I1+N-1 ) )
         DO 10 I = N - 1, 1, -1
C
C           Generate elementary reflector H(i) = I - tau * v * v'
C           to annihilate A(1:i-1,i+1)
C
            ALPHA = AP( I1+I-1 )
            CALL ZLARFG( I, ALPHA, AP( I1 ), 1, TAUI )
            E( I ) = ALPHA
C
            IF( TAUI.NE.ZERO ) THEN
C
C              Apply H(i) from both sides to A(1:i,1:i)
C
               AP( I1+I-1 ) = ONE
C
C              Compute  y := tau * A * v  storing y in TAU(1:i)
C
               CALL YHPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
     $                     1 )
C
C              Compute  w := y - 1/2 * tau * (y'*v) * v
C
               ALPHA = -HALF*TAUI*YDotC( I, TAU, 1, AP( I1 ), 1 )
               CALL YAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
C
C              Apply the transformation as a rank-2 update:
C                 A := A - v * w' - w * v'
C
               CALL YHPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
C
            END IF
            AP( I1+I-1 ) = E( I )
            D( I+1 ) = AP( I1+I )
            TAU( I ) = TAUI
            I1 = I1 - I
   10    CONTINUE
         D( 1 ) = AP( 1 )
      ELSE
C
C        Reduce the lower triangle of A. II is the index in AP of
C        A(i,i) and I1I1 is the index of A(i+1,i+1).
C
         II = 1
         AP( 1 ) = GREAL( AP( 1 ) )
         DO 20 I = 1, N - 1
            I1I1 = II + N - I + 1
C
C           Generate elementary reflector H(i) = I - tau * v * v'
C           to annihilate A(i+2:n,i)
C
            ALPHA = AP( II+1 )
            CALL ZLARFG( N-I, ALPHA, AP( II+2 ), 1, TAUI )
            E( I ) = ALPHA
C
            IF( TAUI.NE.ZERO ) THEN
C
C              Apply H(i) from both sides to A(i+1:n,i+1:n)
C
               AP( II+1 ) = ONE
C
C              Compute  y := tau * A * v  storing y in TAU(i:n-1)
C
               CALL YHPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
     $                     ZERO, TAU( I ), 1 )
C
C              Compute  w := y - 1/2 * tau * (y'*v) * v
C
               ALPHA = -HALF*TAUI*YDotC( N-I, TAU( I ), 1, AP( II+1 ),
     $                 1 )
               CALL YAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
C
C              Apply the transformation as a rank-2 update:
C                 A := A - v * w' - w * v'
C
               CALL YHPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
     $                     AP( I1I1 ) )
C
            END IF
            AP( II+1 ) = E( I )
            D( I ) = AP( II )
            TAU( I ) = TAUI
            II = I1I1
   20    CONTINUE
         D( N ) = AP( II )
      END IF
      RETURN
      END
*Deck ZLABRD
      SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
     $                   LDY )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            LDA, LDX, LDY, M, N, NB
C     ..
C     .. Array Arguments ..
      Real*8   D( * ), E( * )
      COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
     $                   Y( LDY, * )
C     ..
C
C  Purpose
C  =======
C
C  ZLABRD reduces the first NB rows and columns of a complex general
C  m by n matrix A to upper or lower real bidiagonal form by a unitary
C  transformation Q' * A * P, and returns the matrices X and Y which
C  are needed to apply the transformation to the unreduced part of A.
C
C  If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
C  bidiagonal form.
C
C  This is an auxiliary routine called by ZGEBRD
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows in the matrix A.
C
C  N       (input) INTEGER
C          The number of columns in the matrix A.
C
C  NB      (input) INTEGER
C          The number of leading rows and columns of A to be reduced.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the m by n general matrix to be reduced.
C          On exit, the first NB rows and columns of the matrix are
C          overwritten; the rest of the array is unchanged.
C          If m >= n, elements on and below the diagonal in the first NB
C            columns, with the array TAUQ, represent the unitary
C            matrix Q as a product of elementary reflectors; and
C            elements above the diagonal in the first NB rows, with the
C            array TAUP, represent the unitary matrix P as a product
C            of elementary reflectors.
C          If m < n, elements below the diagonal in the first NB
C            columns, with the array TAUQ, represent the unitary
C            matrix Q as a product of elementary reflectors, and
C            elements on and above the diagonal in the first NB rows,
C            with the array TAUP, represent the unitary matrix P as
C            a product of elementary reflectors.
C          See Further Details.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  D       (output) Real*8 array, dimension (NB)
C          The diagonal elements of the first NB rows and columns of
C          the reduced matrix.  D(i) = A(i,i).
C
C  E       (output) Real*8 array, dimension (NB)
C          The off-diagonal elements of the first NB rows and columns of
C          the reduced matrix.
C
C  TAUQ    (output) COMPLEX*16 array dimension (NB)
C          The scalar factors of the elementary reflectors which
C          represent the unitary matrix Q. See Further Details.
C
C  TAUP    (output) COMPLEX*16 array, dimension (NB)
C          The scalar factors of the elementary reflectors which
C          represent the unitary matrix P. See Further Details.
C
C  X       (output) COMPLEX*16 array, dimension (LDX,NB)
C          The m-by-nb matrix X required to update the unreduced part
C          of A.
C
C  LDX     (input) INTEGER
C          The leading dimension of the array X. LDX >= max(1,M).
C
C  Y       (output) COMPLEX*16 array, dimension (LDY,NB)
C          The n-by-nb matrix Y required to update the unreduced part
C          of A.
C
C  LDY     (output) INTEGER
C          The leading dimension of the array Y. LDY >= max(1,N).
C
C  Further Details
C  ===============
C
C  The matrices Q and P are represented as products of elementary
C  reflectors:
C
C     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb)
C
C  Each H(i) and G(i) has the form:
C
C     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
C
C  where tauq and taup are complex scalars, and v and u are complex
C  vectors.
C
C  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
C  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
C  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
C
C  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
C  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
C  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
C
C  The elements of the vectors v and u together form the m-by-nb matrix
C  V and the nb-by-n matrix U' which are needed, with X and Y, to apply
C  the transformation to the unreduced part of the matrix, using a block
C  update of the form:  A := A - V*Y' - X*U'.
C
C  The contents of A on exit are illustrated by the following examples
C  with nb = 2:
C
C  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
C
C    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 )
C    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 )
C    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  )
C    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
C    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
C    (  v1  v2  a   a   a  )
C
C  where a denotes an element of the original matrix which is unchanged,
C  vi denotes an element of the vector defining H(i), and ui an element
C  of the vector defining G(i).
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ZERO, ONE
      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      INTEGER            I
      COMPLEX*16         ALPHA
C     ..
C     .. Executable Statements ..
C
C     Quick return if possible
C
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
C
      IF( M.GE.N ) THEN
C
C        Reduce to upper bidiagonal form
C
         DO 10 I = 1, NB
C
C           Update A(i:m,i)
C
            CALL ZLACGV( I-1, Y( I, 1 ), LDY )
            CALL YGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
     $                  LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
            CALL ZLACGV( I-1, Y( I, 1 ), LDY )
            CALL YGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
     $                  LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
C
C           Generate reflection Q(i) to annihilate A(i+1:m,i)
C
            ALPHA = A( I, I )
            CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
     $                   TAUQ( I ) )
            D( I ) = ALPHA
            IF( I.LT.N ) THEN
               A( I, I ) = ONE
C
C              Compute Y(i+1:n,i)
C
               CALL YGEMV( 'Conjugate transpose', M-I+1, N-I, ONE,
     $                     A( I, I+1 ), LDA, A( I, I ), 1, ZERO,
     $                     Y( I+1, I ), 1 )
               CALL YGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
     $                     A( I, 1 ), LDA, A( I, I ), 1, ZERO,
     $                     Y( 1, I ), 1 )
               CALL YGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
               CALL YGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
     $                     X( I, 1 ), LDX, A( I, I ), 1, ZERO,
     $                     Y( 1, I ), 1 )
               CALL YGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
     $                     A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
     $                     Y( I+1, I ), 1 )
               CALL YScal( N-I, TAUQ( I ), Y( I+1, I ), 1 )
C
C              Update A(i,i+1:n)
C
               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
               CALL ZLACGV( I, A( I, 1 ), LDA )
               CALL YGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
     $                     LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
               CALL ZLACGV( I, A( I, 1 ), LDA )
               CALL ZLACGV( I-1, X( I, 1 ), LDX )
               CALL YGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
     $                     A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE,
     $                     A( I, I+1 ), LDA )
               CALL ZLACGV( I-1, X( I, 1 ), LDX )
C
C              Generate reflection P(i) to annihilate A(i,i+2:n)
C
               ALPHA = A( I, I+1 )
               CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
     $                      TAUP( I ) )
               E( I ) = ALPHA
               A( I, I+1 ) = ONE
C
C              Compute X(i+1:m,i)
C
               CALL YGEMV( '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 YGEMV( 'Conjugate transpose', N-I, I, ONE,
     $                     Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO,
     $                     X( 1, I ), 1 )
               CALL YGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL YGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
     $                     LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
               CALL YGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL YScal( M-I, TAUP( I ), X( I+1, I ), 1 )
               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
            END IF
   10    CONTINUE
      ELSE
C
C        Reduce to lower bidiagonal form
C
         DO 20 I = 1, NB
C
C           Update A(i,i:n)
C
            CALL ZLACGV( N-I+1, A( I, I ), LDA )
            CALL ZLACGV( I-1, A( I, 1 ), LDA )
            CALL YGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
     $                  LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
            CALL ZLACGV( I-1, A( I, 1 ), LDA )
            CALL ZLACGV( I-1, X( I, 1 ), LDX )
            CALL YGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE,
     $                  A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ),
     $                  LDA )
            CALL ZLACGV( I-1, X( I, 1 ), LDX )
C
C           Generate reflection P(i) to annihilate A(i,i+1:n)
C
            ALPHA = A( I, I )
            CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
     $                   TAUP( I ) )
            D( I ) = ALPHA
            IF( I.LT.M ) THEN
               A( I, I ) = ONE
C
C              Compute X(i+1:m,i)
C
               CALL YGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
     $                     LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
               CALL YGEMV( 'Conjugate transpose', N-I+1, I-1, ONE,
     $                     Y( I, 1 ), LDY, A( I, I ), LDA, ZERO,
     $                     X( 1, I ), 1 )
               CALL YGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL YGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
     $                     LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
               CALL YGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL YScal( M-I, TAUP( I ), X( I+1, I ), 1 )
               CALL ZLACGV( N-I+1, A( I, I ), LDA )
C
C              Update A(i+1:m,i)
C
               CALL ZLACGV( I-1, Y( I, 1 ), LDY )
               CALL YGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
     $                     LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
               CALL ZLACGV( I-1, Y( I, 1 ), LDY )
               CALL YGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
     $                     LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
C
C              Generate reflection Q(i) to annihilate A(i+2:m,i)
C
               ALPHA = A( I+1, I )
               CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
     $                      TAUQ( I ) )
               E( I ) = ALPHA
               A( I+1, I ) = ONE
C
C              Compute Y(i+1:n,i)
C
               CALL YGEMV( 'Conjugate transpose', M-I, N-I, ONE,
     $                     A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO,
     $                     Y( I+1, I ), 1 )
               CALL YGEMV( 'Conjugate transpose', M-I, I-1, ONE,
     $                     A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
     $                     Y( 1, I ), 1 )
               CALL YGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
               CALL YGEMV( 'Conjugate transpose', M-I, I, ONE,
     $                     X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO,
     $                     Y( 1, I ), 1 )
               CALL YGEMV( 'Conjugate transpose', I, N-I, -ONE,
     $                     A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
     $                     Y( I+1, I ), 1 )
               CALL YScal( N-I, TAUQ( I ), Y( I+1, I ), 1 )
            ELSE
               CALL ZLACGV( N-I+1, A( I, I ), LDA )
            END IF
   20    CONTINUE
      END IF
      RETURN
      END
*Deck ZLACGV
      SUBROUTINE ZLACGV( N, X, INCX )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INCX, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         X( * )
C     ..
C
C  Purpose
C  =======
C
C  ZLACGV conjugates a complex vector of length N.
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The length of the vector X.  N >= 0.
C
C  X       (input/output) COMPLEX*16 array, dimension
C                         (1+(N-1)*abs(INCX))
C          On entry, the vector of length N to be conjugated.
C          On exit, X is overwritten with conjg(X).
C
C  INCX    (input) INTEGER
C          The spacing between successive elements of X.
C
C =====================================================================
C
C     .. Local Scalars ..
      INTEGER            I, IOFF
      Complex*16          GCONJG
C     ..
C     .. Executable Statements ..
C
      IF( INCX.EQ.1 ) THEN
         DO 10 I = 1, N
            X( I ) = GCONJG( X( I ) )
   10    CONTINUE
      ELSE
         IOFF = 1
         IF( INCX.LT.0 )
     $      IOFF = 1 - ( N-1 )*INCX
         DO 20 I = 1, N
            X( IOFF ) = GCONJG( X( IOFF ) )
            IOFF = IOFF + INCX
   20    CONTINUE
      END IF
      RETURN
      END
*Deck ZLACpy
      SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, LDB, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * )
C     ..
C
C  Purpose
C  =======
C
C  ZLACPY copies all or part of a two-dimensional matrix A to another
C  matrix B.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies the part of the matrix A to be copied to B.
C          = 'U':      Upper triangular part
C          = 'L':      Lower triangular part
C          Otherwise:  All of the matrix A
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input) COMPLEX*16 array, dimension (LDA,N)
C          The m by n matrix A.  If UPLO = 'U', only the upper trapezium
C          is accessed; if UPLO = 'L', only the lower trapezium is
C          accessed.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  B       (output) COMPLEX*16 array, dimension (LDB,N)
C          On exit, B = A in the locations specified by UPLO.
C
C  LDB     (input) INTEGER
C          The leading dimension of the array B.  LDB >= max(1,M).
C
C  =====================================================================
C
C     .. Local Scalars ..
      INTEGER            I, J
      LOGICAL            GLSAME
C     ..
C     .. Executable Statements ..
C
      IF( GLSame( 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
C
      ELSE IF( GLSame( UPLO, 'L' ) ) THEN
         DO 40 J = 1, N
            DO 30 I = J, M
               B( I, J ) = A( I, J )
   30       CONTINUE
   40    CONTINUE
C
      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
*Deck ZLADIV
      Complex*16 Function ZLADIV( X, Y )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      Complex*16         X, Y
C     ..
C
C  Purpose
C  =======
C
C  ZLADIV := X / Y, where X and Y are complex.  The computation of X / Y
C  will not overflow on an intermediary step unless the results
C  overflows.
C
C  Arguments
C  =========
C
C  X       (input) Complex*16
C  Y       (input) Complex*16
C          The complex scalars X and Y.
C
C  =====================================================================
C
C     .. Local Scalars ..
      Complex*16 GCmplx
      Real*8 ZI, ZR
C
      Call DLADIV(GREAL(X),GIMAG(X),GREAL(Y),GIMAG(Y),ZR,ZI)
      ZLADiv = GCmplx(ZR,ZI)
      Return
      End
*Deck ZLANGE
      Real*8 FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            LDA, M, N
C     ..
C     .. Array Arguments ..
      Real*8   WORK( * )
      COMPLEX*16         A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  ZLANGE  returns the value of the one norm,  or the Frobenius norm, or
C  the  infinity norm,  or the  element of  largest absolute value  of a
C  complex matrix A.
C
C  Description
C  ===========
C
C  ZLANGE returns the value
C
C     ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
C              (
C              ( norm1(A),         NORM = '1', 'O' or 'o'
C              (
C              ( normI(A),         NORM = 'I' or 'i'
C              (
C              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
C
C  where  norm1  denotes the  one norm of a matrix (maximum column sum),
C  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
C  normF  denotes the  Frobenius norm of a matrix (square root of sum of
C  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
C
C  Arguments
C  =========
C
C  NORM    (input) CHARACTER*1
C          Specifies the value to be returned in ZLANGE as described
C          above.
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.  When M = 0,
C          ZLANGE is set to zero.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.  When N = 0,
C          ZLANGE is set to zero.
C
C  A       (input) COMPLEX*16 array, dimension (LDA,N)
C          The m by n matrix A.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(M,1).
C
C  WORK    (workspace) Real*8 array, dimension (LWORK),
C          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
C          referenced.
C
C =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, J
      Real*8   SCALE, SUM, VALUE
      LOGICAL            GLSAME
C     ..
C     .. Executable Statements ..
C
      IF( MIN( M, N ).EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( GLSame( NORM, 'M' ) ) THEN
C
C        Find max(abs(A(i,j))).
C
         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( ( GLSame( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
C
C        Find norm1(A).
C
         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( GLSame( NORM, 'I' ) ) THEN
C
C        Find normI(A).
C
         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( ( GLSame( NORM, 'F' ) ) .OR. (GLSame( NORM,'E'))) THEN
C
C        Find normF(A).
C
         SCALE = ZERO
         SUM = ONE
         DO 90 J = 1, N
            CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM )
   90    CONTINUE
         VALUE = SCALE*SQRT( SUM )
      END IF
      ZLANGE = VALUE
      RETURN
      END
*Deck ZLanHP
      FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          NORM, UPLO
      INTEGER            N
C     ..
C     .. Array Arguments ..
      Real*8   WORK( * )
      COMPLEX*16         AP( * )
C     ..
C
C  Purpose
C  =======
C
C  ZLANHP  returns the value of the one norm,  or the Frobenius norm, or
C  the  infinity norm,  or the  element of  largest absolute value  of a
C  complex hermitian matrix A,  supplied in packed form.
C
C  Description
C  ===========
C
C  ZLANHP returns the value
C
C     ZLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
C              (
C              ( norm1(A),         NORM = '1', 'O' or 'o'
C              (
C              ( normI(A),         NORM = 'I' or 'i'
C              (
C              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
C
C  where  norm1  denotes the  one norm of a matrix (maximum column sum),
C  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
C  normF  denotes the  Frobenius norm of a matrix (square root of sum of
C  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
C
C  Arguments
C  =========
C
C  NORM    (input) CHARACTER*1
C          Specifies the value to be returned in ZLANHP as described
C          above.
C
C  UPLO    (input) CHARACTER*1
C          Specifies whether the upper or lower triangular part of the
C          hermitian matrix A is supplied.
C          = 'U':  Upper triangular part of A is supplied
C          = 'L':  Lower triangular part of A is supplied
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.  When N = 0, ZLANHP is
C          set to zero.
C
C  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
C          The upper or lower triangle of the hermitian matrix A, packed
C          columnwise in a linear array.  The j-th column of A is stored
C          in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
C          Note that the  imaginary parts of the diagonal elements need
C          not be set and are assumed to be zero.
C
C  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK),
C          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
C          WORK is not referenced.
C
C =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, J, K
      Real*8   ABSA, SCALE, SUM, VALUE
      LOGICAL            GLSame
C
      IF( N.EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( GLSame( NORM, 'M' ) ) THEN
C
C        Find max(abs(A(i,j))).
C
         VALUE = ZERO
         IF( GLSame( UPLO, 'U' ) ) THEN
            K = 0
            DO 20 J = 1, N
               DO 10 I = K + 1, K + J - 1
                  VALUE = MAX( VALUE, ABS( AP( I ) ) )
   10          CONTINUE
               K = K + J
               VALUE = MAX( VALUE, ABS( GREAL( AP( K ) ) ) )
   20       CONTINUE
         ELSE
            K = 1
            DO 40 J = 1, N
               VALUE = MAX( VALUE, ABS( GREAL( AP( K ) ) ) )
               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 IF( ( GLSame( NORM, 'I' ) ) .OR. ( GLSame( NORM, 'O' ) ) .OR.
     $         ( NORM.EQ.'1' ) ) THEN
C
C        Find normI(A) ( = norm1(A), since A is hermitian).
C
         VALUE = ZERO
         K = 1
         IF( GLSame( 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( GREAL( 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( GREAL( 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( ( GLSame( NORM, 'F' ) ) .OR. ( GLSame( NORM, 'E' )))THEN
C
C        Find normF(A).
C
         SCALE = ZERO
         SUM = ONE
         K = 2
         IF( GLSame( UPLO, 'U' ) ) THEN
            DO 110 J = 2, N
               CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM )
               K = K + J
  110       CONTINUE
         ELSE
            DO 120 J = 1, N - 1
               CALL ZLASSQ( 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( GREAL( AP( K ) ).NE.ZERO ) THEN
               ABSA = ABS( GREAL( 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( GLSame( UPLO, 'U' ) ) THEN
               K = K + I + 1
            ELSE
               K = K + N - I + 1
            END IF
  130    CONTINUE
         VALUE = SCALE*SQRT( SUM )
      END IF
      ZLANHP = VALUE
      RETURN
      END
*Deck ZLARF
      SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            INCV, LDC, M, N
      COMPLEX*16         TAU
C     ..
C     .. Array Arguments ..
      COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  ZLARF applies a complex elementary reflector H to a complex M-by-N
C  matrix C, from either the left or the right. H is represented in the
C  form
C
C        H = I - tau * v * v'
C
C  where tau is a complex scalar and v is a complex vector.
C
C  If tau = 0, then H is taken to be the unit matrix.
C
C  To apply H' (the conjugate transpose of H), supply conjg(tau) instead
C  tau.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': form  H * C
C          = 'R': form  C * H
C
C  M       (input) INTEGER
C          The number of rows of the matrix C.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C.
C
C  V       (input) COMPLEX*16 array, dimension
C                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
C                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
C          The vector v in the representation of H. V is not used if
C          TAU = 0.
C
C  INCV    (input) INTEGER
C          The increment between elements of v. INCV <> 0.
C
C  TAU     (input) COMPLEX*16
C          The value tau in the representation of H.
C
C  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
C          On entry, the M-by-N matrix C.
C          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
C          or C * H if SIDE = 'R'.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace) COMPLEX*16 array, dimension
C                         (N) if SIDE = 'L'
C                      or (M) if SIDE = 'R'
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
      LOGICAL            GLSame
C
      IF( GLSame( SIDE, 'L' ) ) THEN
C
C        Form  H * C
C
         IF( TAU.NE.ZERO ) THEN
C
C           w := C' * v
C
            CALL YGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V,
     $                  INCV, ZERO, WORK, 1 )
C
C           C := C - v * w'
C
            CALL YGERC( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
         END IF
      ELSE
C
C        Form  C * H
C
         IF( TAU.NE.ZERO ) THEN
C
C           w := C * v
C
            CALL YGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
     $                  ZERO, WORK, 1 )
C
C           C := C - w * v'
C
            CALL YGERC( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
         END IF
      END IF
      RETURN
      END
*Deck ZLARFB
      SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
     $                   T, LDT, C, LDC, WORK, LDWORK )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          DIRECT, SIDE, STOREV, TRANS
      INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         C( LDC, * ), T( LDT, * ), V( LDV, * ),
     $                   WORK( LDWORK, * )
C     ..
C
C  Purpose
C  =======
C
C  ZLARFB applies a complex block reflector H or its transpose H' to a
C  complex M-by-N matrix C, from either the left or the right.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': apply H or H' from the Left
C          = 'R': apply H or H' from the Right
C
C  TRANS   (input) CHARACTER*1
C          = 'N': apply H (No transpose)
C          = 'C': apply H' (Conjugate transpose)
C
C  DIRECT  (input) CHARACTER*1
C          Indicates how H is formed from a product of elementary
C          reflectors
C          = 'F': H = H(1) H(2) . . . H(k) (Forward)
C          = 'B': H = H(k) . . . H(2) H(1) (Backward)
C
C  STOREV  (input) CHARACTER*1
C          Indicates how the vectors which define the elementary
C          reflectors are stored:
C          = 'C': Columnwise
C          = 'R': Rowwise
C
C  M       (input) INTEGER
C          The number of rows of the matrix C.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C.
C
C  K       (input) INTEGER
C          The order of the matrix T (= the number of elementary
C          reflectors whose product defines the block reflector).
C
C  V       (input) COMPLEX*16 array, dimension
C                                (LDV,K) if STOREV = 'C'
C                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
C                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
C          The matrix V. See further details.
C
C  LDV     (input) INTEGER
C          The leading dimension of the array V.
C          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
C          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
C          if STOREV = 'R', LDV >= K.
C
C  T       (input) COMPLEX*16 array, dimension (LDT,K)
C          The triangular K-by-K matrix T in the representation of the
C          block reflector.
C
C  LDT     (input) INTEGER
C          The leading dimension of the array T. LDT >= K.
C
C  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
C          On entry, the M-by-N matrix C.
C          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,K)
C
C  LDWORK  (input) INTEGER
C          The leading dimension of the array WORK.
C          If SIDE = 'L', LDWORK >= max(1,N);
C          if SIDE = 'R', LDWORK >= max(1,M).
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ONE, GCONJG
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      CHARACTER          TRANST
      INTEGER            I, J
      LOGICAL            GLSAME
C     ..
C     .. Executable Statements ..
C
C     Quick return if possible
C
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
C
      IF( GLSame( TRANS, 'N' ) ) THEN
         TRANST = 'C'
      ELSE
         TRANST = 'N'
      END IF
C
      IF( GLSame( STOREV, 'C' ) ) THEN
C
         IF( GLSame( DIRECT, 'F' ) ) THEN
C
C           Let  V =  ( V1 )    (first K rows)
C                     ( V2 )
C           where  V1  is unit lower triangular.
C
            IF( GLSame( SIDE, 'L' ) ) THEN
C
C              Form  H * C  or  H' * C  where  C = ( C1 )
C                                                  ( C2 )
C
C              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
C
C              W := C1'
C
               DO 10 J = 1, K
                  CALL YCopy( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
                  CALL ZLACGV( N, WORK( 1, J ), 1 )
   10          CONTINUE
C
C              W := W * V1
C
               CALL YTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
     $                     K, ONE, V, LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
C
C                 W := W + C2'*V2
C
                  CALL YGEMM( 'Conjugate transpose', 'No transpose', N,
     $                        K, M-K, ONE, C( K+1, 1 ), LDC,
     $                        V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
               END IF
C
C              W := W * T'  or  W * T
C
               CALL YTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - V * W'
C
               IF( M.GT.K ) THEN
C
C                 C2 := C2 - V2 * W'
C
                  CALL YGEMM( 'No transpose', 'Conjugate transpose',
     $                        M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK,
     $                        LDWORK, ONE, C( K+1, 1 ), LDC )
               END IF
C
C              W := W * V1'
C
               CALL YTRMM( 'Right', 'Lower', 'Conjugate transpose',
     $                     'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
C
C              C1 := C1 - W'
C
               DO 30 J = 1, K
                  DO 20 I = 1, N
                     C( J, I ) = C( J, I ) - GCONJG( WORK( I, J ) )
   20             CONTINUE
   30          CONTINUE
C
            ELSE IF( GLSame( SIDE, 'R' ) ) THEN
C
C              Form  C * H  or  C * H'  where  C = ( C1  C2 )
C
C              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
C
C              W := C1
C
               DO 40 J = 1, K
                  CALL YCopy( M, C( 1, J ), 1, WORK( 1, J ), 1 )
   40          CONTINUE
C
C              W := W * V1
C
               CALL YTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
     $                     K, ONE, V, LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
C
C                 W := W + C2 * V2
C
                  CALL YGEMM( 'No transpose', 'No transpose', M, K, N-K,
     $                        ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
     $                        ONE, WORK, LDWORK )
               END IF
C
C              W := W * T  or  W * T'
C
               CALL YTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - W * V'
C
               IF( N.GT.K ) THEN
C
C                 C2 := C2 - W * V2'
C
                  CALL YGEMM( 'No transpose', 'Conjugate transpose', M,
     $                        N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ),
     $                        LDV, ONE, C( 1, K+1 ), LDC )
               END IF
C
C              W := W * V1'
C
               CALL YTRMM( 'Right', 'Lower', 'Conjugate transpose',
     $                     'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
C
C              C1 := C1 - W
C
               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
C
         ELSE
C
C           Let  V =  ( V1 )
C                     ( V2 )    (last K rows)
C           where  V2  is unit upper triangular.
C
            IF( GLSame( SIDE, 'L' ) ) THEN
C
C              Form  H * C  or  H' * C  where  C = ( C1 )
C                                                  ( C2 )
C
C              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
C
C              W := C2'
C
               DO 70 J = 1, K
                  CALL YCopy( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
                  CALL ZLACGV( N, WORK( 1, J ), 1 )
   70          CONTINUE
C
C              W := W * V2
C
               CALL YTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
     $                     K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
C
C                 W := W + C1'*V1
C
                  CALL YGEMM( 'Conjugate transpose', 'No transpose', N,
     $                        K, M-K, ONE, C, LDC, V, LDV, ONE, WORK,
     $                        LDWORK )
               END IF
C
C              W := W * T'  or  W * T
C
               CALL YTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - V * W'
C
               IF( M.GT.K ) THEN
C
C                 C1 := C1 - V1 * W'
C
                  CALL YGEMM( 'No transpose', 'Conjugate transpose',
     $                        M-K, N, K, -ONE, V, LDV, WORK, LDWORK,
     $                        ONE, C, LDC )
               END IF
C
C              W := W * V2'
C
               CALL YTRMM( 'Right', 'Upper', 'Conjugate transpose',
     $                     'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK,
     $                     LDWORK )
C
C              C2 := C2 - W'
C
               DO 90 J = 1, K
                  DO 80 I = 1, N
                     C( M-K+J, I ) = C( M-K+J, I ) -
     $                               GCONJG( WORK( I, J ) )
   80             CONTINUE
   90          CONTINUE
C
            ELSE IF( GLSame( SIDE, 'R' ) ) THEN
C
C              Form  C * H  or  C * H'  where  C = ( C1  C2 )
C
C              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
C
C              W := C2
C
               DO 100 J = 1, K
                  CALL YCopy( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
  100          CONTINUE
C
C              W := W * V2
C
               CALL YTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
     $                     K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
C
C                 W := W + C1 * V1
C
                  CALL YGEMM( 'No transpose', 'No transpose', M, K, N-K,
     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
C
C              W := W * T  or  W * T'
C
               CALL YTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - W * V'
C
               IF( N.GT.K ) THEN
C
C                 C1 := C1 - W * V1'
C
                  CALL YGEMM( 'No transpose', 'Conjugate transpose', M,
     $                        N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE,
     $                        C, LDC )
               END IF
C
C              W := W * V2'
C
               CALL YTRMM( 'Right', 'Upper', 'Conjugate transpose',
     $                     'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK,
     $                     LDWORK )
C
C              C2 := C2 - W
C
               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
C
      ELSE IF( GLSame( STOREV, 'R' ) ) THEN
C
         IF( GLSame( DIRECT, 'F' ) ) THEN
C
C           Let  V =  ( V1  V2 )    (V1: first K columns)
C           where  V1  is unit upper triangular.
C
            IF( GLSame( SIDE, 'L' ) ) THEN
C
C              Form  H * C  or  H' * C  where  C = ( C1 )
C                                                  ( C2 )
C
C              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
C
C              W := C1'
C
               DO 130 J = 1, K
                  CALL YCopy( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
                  CALL ZLACGV( N, WORK( 1, J ), 1 )
  130          CONTINUE
C
C              W := W * V1'
C
               CALL YTRMM( 'Right', 'Upper', 'Conjugate transpose',
     $                     'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
C
C                 W := W + C2'*V2'
C
                  CALL YGEMM( 'Conjugate transpose',
     $                        'Conjugate transpose', N, K, M-K, ONE,
     $                        C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
     $                        WORK, LDWORK )
               END IF
C
C              W := W * T'  or  W * T
C
               CALL YTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - V' * W'
C
               IF( M.GT.K ) THEN
C
C                 C2 := C2 - V2' * W'
C
                  CALL YGEMM( 'Conjugate transpose',
     $                        'Conjugate transpose', M-K, N, K, -ONE,
     $                        V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
     $                        C( K+1, 1 ), LDC )
               END IF
C
C              W := W * V1
C
               CALL YTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
     $                     K, ONE, V, LDV, WORK, LDWORK )
C
C              C1 := C1 - W'
C
               DO 150 J = 1, K
                  DO 140 I = 1, N
                     C( J, I ) = C( J, I ) - GCONJG( WORK( I, J ) )
  140             CONTINUE
  150          CONTINUE
C
            ELSE IF( GLSame( SIDE, 'R' ) ) THEN
C
C              Form  C * H  or  C * H'  where  C = ( C1  C2 )
C
C              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
C
C              W := C1
C
               DO 160 J = 1, K
                  CALL YCopy( M, C( 1, J ), 1, WORK( 1, J ), 1 )
  160          CONTINUE
C
C              W := W * V1'
C
               CALL YTRMM( 'Right', 'Upper', 'Conjugate transpose',
     $                     'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
C
C                 W := W + C2 * V2'
C
                  CALL YGEMM( 'No transpose', 'Conjugate transpose', M,
     $                        K, N-K, ONE, C( 1, K+1 ), LDC,
     $                        V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
               END IF
C
C              W := W * T  or  W * T'
C
               CALL YTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - W * V
C
               IF( N.GT.K ) THEN
C
C                 C2 := C2 - W * V2
C
                  CALL YGEMM( 'No transpose', 'No transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
     $                        C( 1, K+1 ), LDC )
               END IF
C
C              W := W * V1
C
               CALL YTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
     $                     K, ONE, V, LDV, WORK, LDWORK )
C
C              C1 := C1 - W
C
               DO 180 J = 1, K
                  DO 170 I = 1, M
                     C( I, J ) = C( I, J ) - WORK( I, J )
  170             CONTINUE
  180          CONTINUE
C
            END IF
C
         ELSE
C
C           Let  V =  ( V1  V2 )    (V2: last K columns)
C           where  V2  is unit lower triangular.
C
            IF( GLSame( SIDE, 'L' ) ) THEN
C
C              Form  H * C  or  H' * C  where  C = ( C1 )
C                                                  ( C2 )
C
C              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
C
C              W := C2'
C
               DO 190 J = 1, K
                  CALL YCopy( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
                  CALL ZLACGV( N, WORK( 1, J ), 1 )
  190          CONTINUE
C
C              W := W * V2'
C
               CALL YTRMM( 'Right', 'Lower', 'Conjugate transpose',
     $                     'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK,
     $                     LDWORK )
               IF( M.GT.K ) THEN
C
C                 W := W + C1'*V1'
C
                  CALL YGEMM( 'Conjugate transpose',
     $                        'Conjugate transpose', N, K, M-K, ONE, C,
     $                        LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
C
C              W := W * T'  or  W * T
C
               CALL YTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - V' * W'
C
               IF( M.GT.K ) THEN
C
C                 C1 := C1 - V1' * W'
C
                  CALL YGEMM( 'Conjugate transpose',
     $                        'Conjugate transpose', M-K, N, K, -ONE, V,
     $                        LDV, WORK, LDWORK, ONE, C, LDC )
               END IF
C
C              W := W * V2
C
               CALL YTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
     $                     K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
C
C              C2 := C2 - W'
C
               DO 210 J = 1, K
                  DO 200 I = 1, N
                     C( M-K+J, I ) = C( M-K+J, I ) -
     $                               GCONJG( WORK( I, J ) )
  200             CONTINUE
  210          CONTINUE
C
            ELSE IF( GLSame( SIDE, 'R' ) ) THEN
C
C              Form  C * H  or  C * H'  where  C = ( C1  C2 )
C
C              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
C
C              W := C2
C
               DO 220 J = 1, K
                  CALL YCopy( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
  220          CONTINUE
C
C              W := W * V2'
C
               CALL YTRMM( 'Right', 'Lower', 'Conjugate transpose',
     $                     'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK,
     $                     LDWORK )
               IF( N.GT.K ) THEN
C
C                 W := W + C1 * V1'
C
                  CALL YGEMM( 'No transpose', 'Conjugate transpose', M,
     $                        K, N-K, ONE, C, LDC, V, LDV, ONE, WORK,
     $                        LDWORK )
               END IF
C
C              W := W * T  or  W * T'
C
               CALL YTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
C
C              C := C - W * V
C
               IF( N.GT.K ) THEN
C
C                 C1 := C1 - W * V1
C
                  CALL YGEMM( 'No transpose', 'No transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
               END IF
C
C              W := W * V2
C
               CALL YTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
     $                     K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
C
C              C1 := C1 - W
C
               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
C
            END IF
C
         END IF
      END IF
      RETURN
      END
*Deck ZLARFG
      SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
      INTEGER            INCX, N
      COMPLEX*16         ALPHA, TAU
      COMPLEX*16         X( * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  ZLARFG generates a complex elementary reflector H of order n, such
C  that
C
C        H' * ( alpha ) = ( beta ),   H' * H = I.
C             (   x   )   (   0  )
C
C  where alpha and beta are scalars, with beta real, and x is an
C  (n-1)-element complex vector. H is represented in the form
C
C        H = I - tau * ( 1 ) * ( 1 v' ) ,
C                      ( v )
C
C  where tau is a complex scalar and v is a complex (n-1)-element
C  vector. Note that H is not hermitian.
C
C  If the elements of x are all zero and alpha is real, then tau = 0
C  and H is taken to be the unit matrix.
C
C  Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The order of the elementary reflector.
C
C  ALPHA   (input/output) COMPLEX*16
C          On entry, the value alpha.
C          On exit, it is overwritten with the value beta.
C
C  X       (input/output) COMPLEX*16 array, dimension
C                         (1+(N-2)*abs(INCX))
C          On entry, the vector x.
C          On exit, it is overwritten with the vector v.
C
C  INCX    (input) INTEGER
C          The increment between elements of X. INCX > 0.
C
C  TAU     (output) COMPLEX*16
C          The value tau.
C
C  =====================================================================
C
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      INTEGER            J, KNT
      Real*8 ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
      Real*8   DLAPY3, GZNRM2
      COMPLEX*16         ZLADIV,GCmplx
C
      IF( N.LE.0 ) THEN
         TAU = ZERO
         RETURN
      END IF
C
      XNORM = GZNrm2( N-1, X, INCX )
      ALPHR = GREAL( ALPHA)
      ALPHI = GIMAG( ALPHA )
C
      IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
C
C        H  =  I
C
         TAU = ZERO
      ELSE
C
C        general case
C
         BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
         SAFMIN = SFMin / Eps
         RSAFMN = ONE / SAFMIN
C
         IF( ABS( BETA ).LT.SAFMIN ) THEN
C
C           XNORM, BETA may be inaccurate; scale X and recompute them
C
            KNT = 0
   10       CONTINUE
            KNT = KNT + 1
            CALL YDScal( N-1, RSAFMN, X, INCX )
            BETA = BETA*RSAFMN
            ALPHI = ALPHI*RSAFMN
            ALPHR = ALPHR*RSAFMN
            IF( ABS( BETA ).LT.SAFMIN )
     $         GO TO 10
C
C           New BETA is at most 1, at least SAFMIN
C
            XNORM = GZNrm2( N-1, X, INCX )
            ALPHA = GCmplx( ALPHR, ALPHI )
            BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
            TAU = GCmplx( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
            ALPHA = ZLADIV( GCmplx( ONE , ZERO), ALPHA-BETA )
            CALL YScal( N-1, ALPHA, X, INCX )
C
C           If ALPHA is subnormal, it may lose relative accuracy
C
            ALPHA = BETA
            DO 20 J = 1, KNT
               ALPHA = ALPHA*SAFMIN
   20       CONTINUE
         ELSE
            TAU = GCmplx( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
            ALPHA = ZLADIV( GCmplx( ONE , Zero), ALPHA-BETA )
            CALL YScal( N-1, ALPHA, X, INCX )
            ALPHA = BETA
         END IF
      END IF
      RETURN
      END
*Deck ZLARFT
      SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          DIRECT, STOREV
      INTEGER            K, LDT, LDV, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         T( LDT, * ), TAU( * ), V( LDV, * )
C     ..
C
C  Purpose
C  =======
C
C  ZLARFT forms the triangular factor T of a complex block reflector H
C  of order n, which is defined as a product of k elementary reflectors.
C
C  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
C
C  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
C
C  If STOREV = 'C', the vector which defines the elementary reflector
C  H(i) is stored in the i-th column of the array V, and
C
C     H  =  I - V * T * V'
C
C  If STOREV = 'R', the vector which defines the elementary reflector
C  H(i) is stored in the i-th row of the array V, and
C
C     H  =  I - V' * T * V
C
C  Arguments
C  =========
C
C  DIRECT  (input) CHARACTER*1
C          Specifies the order in which the elementary reflectors are
C          multiplied to form the block reflector:
C          = 'F': H = H(1) H(2) . . . H(k) (Forward)
C          = 'B': H = H(k) . . . H(2) H(1) (Backward)
C
C  STOREV  (input) CHARACTER*1
C          Specifies how the vectors which define the elementary
C          reflectors are stored (see also Further Details):
C          = 'C': columnwise
C          = 'R': rowwise
C
C  N       (input) INTEGER
C          The order of the block reflector H. N >= 0.
C
C  K       (input) INTEGER
C          The order of the triangular factor T (= the number of
C          elementary reflectors). K >= 1.
C
C  V       (input/output) COMPLEX*16 array, dimension
C                               (LDV,K) if STOREV = 'C'
C                               (LDV,N) if STOREV = 'R'
C          The matrix V. See further details.
C
C  LDV     (input) INTEGER
C          The leading dimension of the array V.
C          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
C
C  TAU     (input) COMPLEX*16 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i).
C
C  T       (output) COMPLEX*16 array, dimension (LDT,K)
C          The k by k triangular factor T of the block reflector.
C          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
C          lower triangular. The rest of the array is not used.
C
C  LDT     (input) INTEGER
C          The leading dimension of the array T. LDT >= K.
C
C  Further Details
C  ===============
C
C  The shape of the matrix V and the storage of the vectors which define
C  the H(i) is best illustrated by the following example with n = 5 and
C  k = 3. The elements equal to 1 are not stored; the corresponding
C  array elements are modified but restored on exit. The rest of the
C  array is not used.
C
C  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
C
C               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
C                   ( v1  1    )                     (     1 v2 v2 v2 )
C                   ( v1 v2  1 )                     (        1 v3 v3 )
C                   ( v1 v2 v3 )
C                   ( v1 v2 v3 )
C
C  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
C
C               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
C                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
C                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
C                   (     1 v3 )
C                   (        1 )
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      INTEGER            I, J
      COMPLEX*16         VII
      LOGICAL            GLSAME
C     ..
C     .. Executable Statements ..
C
C     Quick return if possible
C
      IF( N.EQ.0 )
     $   RETURN
C
      IF( GLSame( DIRECT, 'F' ) ) THEN
         DO 20 I = 1, K
            IF( TAU( I ).EQ.ZERO ) THEN
C
C              H(i)  =  I
C
               DO 10 J = 1, I
                  T( J, I ) = ZERO
   10          CONTINUE
            ELSE
C
C              general case
C
               VII = V( I, I )
               V( I, I ) = ONE
               IF( GLSame( STOREV, 'C' ) ) THEN
C
C                 T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
C
                  CALL YGEMV( 'Conjugate transpose', N-I+1, I-1,
     $                        -TAU( I ), V( I, 1 ), LDV, V( I, I ), 1,
     $                        ZERO, T( 1, I ), 1 )
               ELSE
C
C                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
C
                  IF( I.LT.N )
     $               CALL ZLACGV( N-I, V( I, I+1 ), LDV )
                  CALL YGEMV( 'No transpose', I-1, N-I+1, -TAU( I ),
     $                        V( 1, I ), LDV, V( I, I ), LDV, ZERO,
     $                        T( 1, I ), 1 )
                  IF( I.LT.N )
     $               CALL ZLACGV( N-I, V( I, I+1 ), LDV )
               END IF
               V( I, I ) = VII
C
C              T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
C
               CALL YTRMV( '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
C
C              H(i)  =  I
C
               DO 30 J = I, K
                  T( J, I ) = ZERO
   30          CONTINUE
            ELSE
C
C              general case
C
               IF( I.LT.K ) THEN
                  IF( GLSame( STOREV, 'C' ) ) THEN
                     VII = V( N-K+I, I )
                     V( N-K+I, I ) = ONE
C
C                    T(i+1:k,i) :=
C                            - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
C
                     CALL YGEMV( 'Conjugate 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
C
C                    T(i+1:k,i) :=
C                            - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
C
                     CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV )
                     CALL YGEMV( 'No transpose', K-I, N-K+I, -TAU( I ),
     $                           V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
     $                           T( I+1, I ), 1 )
                     CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV )
                     V( I, N-K+I ) = VII
                  END IF
C
C                 T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
C
                  CALL YTRMV( '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
*Deck ZLAScl
      SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
      CHARACTER          TYPE
      INTEGER            INFO, KL, KU, LDA, M, N
      Real*8   CFROM, CTO
      COMPLEX*16         A( LDA, * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  ZLASCL multiplies the M by N complex matrix A by the real scalar
C  CTO/CFROM.  This is done without over/underflow as long as the final
C  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
C  A may be full, upper triangular, lower triangular, upper Hessenberg,
C  or banded.
C
C  Arguments
C  =========
C
C  TYPE    (input) CHARACTER*1
C          TYPE indices the storage type of the input matrix.
C          = 'G':  A is a full matrix.
C          = 'L':  A is a lower triangular matrix.
C          = 'U':  A is an upper triangular matrix.
C          = 'H':  A is an upper Hessenberg matrix.
C          = 'B':  A is a symmetric band matrix with lower bandwidth KL
C                  and upper bandwidth KU and with the only the lower
C                  half stored.
C          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
C                  and upper bandwidth KU and with the only the upper
C                  half stored.
C          = 'Z':  A is a band matrix with lower bandwidth KL and upper
C                  bandwidth KU.
C
C  KL      (input) INTEGER
C          The lower bandwidth of A.  Referenced only if TYPE = 'B',
C          'Q' or 'Z'.
C
C  KU      (input) INTEGER
C          The upper bandwidth of A.  Referenced only if TYPE = 'B',
C          'Q' or 'Z'.
C
C  CFROM   (input) Real*8
C  CTO     (input) Real*8
C          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
C          without over/underflow if the final result CTO*A(I,J)/CFROM
C          can be represented without over/underflow.  CFROM must be
C          nonzero.
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,M)
C          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
C          storage type.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  INFO    (output) INTEGER
C          0  - successful exit
C          <0 - if INFO = -i, the i-th argument had an illegal value.
C
C  =====================================================================
C
      Real*8   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
      LOGICAL            DONE
      INTEGER            I, ITYPE, J, K1, K2, K3, K4
      Real*8   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
      LOGICAL            GLSAME
C
C     Test the input arguments
C
      INFO = 0
C
      IF( GLSame( TYPE, 'G' ) ) THEN
         ITYPE = 0
      ELSE IF( GLSame( TYPE, 'L' ) ) THEN
         ITYPE = 1
      ELSE IF( GLSame( TYPE, 'U' ) ) THEN
         ITYPE = 2
      ELSE IF( GLSame( TYPE, 'H' ) ) THEN
         ITYPE = 3
      ELSE IF( GLSame( TYPE, 'B' ) ) THEN
         ITYPE = 4
      ELSE IF( GLSame( TYPE, 'Q' ) ) THEN
         ITYPE = 5
      ELSE IF( GLSame( TYPE, 'Z' ) ) THEN
         ITYPE = 6
      ELSE
         ITYPE = -1
      END IF
C
      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) Call GLBErr('ZLAScl',Info)
      If(N.eq.0.or.M.eq.0) RETURN
C
C     Get machine parameters
C
      SMLNUM = SFMin
      BIGNUM = ONE / SMLNUM
C
      CFROMC = CFROM
      CTOC = CTO
C
   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
C
      IF( ITYPE.EQ.0 ) THEN
C
C        Full matrix
C
         DO 30 J = 1, N
            DO 20 I = 1, M
               A( I, J ) = A( I, J )*MUL
   20       CONTINUE
   30    CONTINUE
C
      ELSE IF( ITYPE.EQ.1 ) THEN
C
C        Lower triangular matrix
C
         DO 50 J = 1, N
            DO 40 I = J, M
               A( I, J ) = A( I, J )*MUL
   40       CONTINUE
   50    CONTINUE
C
      ELSE IF( ITYPE.EQ.2 ) THEN
C
C        Upper triangular matrix
C
         DO 70 J = 1, N
            DO 60 I = 1, MIN( J, M )
               A( I, J ) = A( I, J )*MUL
   60       CONTINUE
   70    CONTINUE
C
      ELSE IF( ITYPE.EQ.3 ) THEN
C
C        Upper Hessenberg matrix
C
         DO 90 J = 1, N
            DO 80 I = 1, MIN( J+1, M )
               A( I, J ) = A( I, J )*MUL
   80       CONTINUE
   90    CONTINUE
C
      ELSE IF( ITYPE.EQ.4 ) THEN
C
C        Lower half of a symmetric band matrix
C
         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
C
      ELSE IF( ITYPE.EQ.5 ) THEN
C
C        Upper half of a symmetric band matrix
C
         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
C
      ELSE IF( ITYPE.EQ.6 ) THEN
C
C        Band matrix
C
         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
C
      END IF
C
      IF( .NOT.DONE )
     $   GO TO 10
      RETURN
      END
*Deck ZLASET
      SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, M, N
      COMPLEX*16         ALPHA, BETA
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  ZLASET initializes a 2-D array A to BETA on the diagonal and
C  ALPHA on the offdiagonals.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies the part of the matrix A to be set.
C          = 'U':      Upper triangular part is set. The lower triangle
C                      is unchanged.
C          = 'L':      Lower triangular part is set. The upper triangle
C                      is unchanged.
C          Otherwise:  All of the matrix A is set.
C
C  M       (input) INTEGER
C          On entry, M specifies the number of rows of A.
C
C  N       (input) INTEGER
C          On entry, N specifies the number of columns of A.
C
C  ALPHA   (input) COMPLEX*16
C          All the offdiagonal array elements are set to ALPHA.
C
C  BETA    (input) COMPLEX*16
C          All the diagonal array elements are set to BETA.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the m by n matrix A.
C          On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;
C                   A(i,i) = BETA , 1 <= i <= min(m,n)
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  =====================================================================
C
C     .. Local Scalars ..
      INTEGER            I, J
      LOGICAL            GLSame
C
      IF( GLSame( UPLO, 'U' ) ) THEN
C
C        Set the diagonal to BETA and the strictly upper triangular
C        part of the array to ALPHA.
C
         DO 20 J = 2, N
            DO 10 I = 1, MIN( J-1, M )
               A( I, J ) = ALPHA
   10       CONTINUE
   20    CONTINUE
         DO 30 I = 1, MIN( N, M )
            A( I, I ) = BETA
   30    CONTINUE
C
      ELSE IF( GLSame( UPLO, 'L' ) ) THEN
C
C        Set the diagonal to BETA and the strictly lower triangular
C        part of the array to ALPHA.
C
         DO 50 J = 1, MIN( M, N )
            DO 40 I = J + 1, M
               A( I, J ) = ALPHA
   40       CONTINUE
   50    CONTINUE
         DO 60 I = 1, MIN( N, M )
            A( I, I ) = BETA
   60    CONTINUE
C
      ELSE
C
C        Set the array to BETA on the diagonal and ALPHA on the
C        offdiagonal.
C
         DO 80 J = 1, N
            DO 70 I = 1, M
               A( I, J ) = ALPHA
   70       CONTINUE
   80    CONTINUE
         DO 90 I = 1, MIN( M, N )
            A( I, I ) = BETA
   90    CONTINUE
      END IF
      RETURN
      END
*Deck ZLASR
      SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     October 31, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          DIRECT, PIVOT, SIDE
      INTEGER            LDA, M, N
C     ..
C     .. Array Arguments ..
      Real*8   C( * ), S( * )
      COMPLEX*16         A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  ZLASR   performs the transformation
C
C     A := P*A,   when SIDE = 'L' or 'l'  (  Left-hand side )
C
C     A := A*P',  when SIDE = 'R' or 'r'  ( Right-hand side )
C
C  where A is an m by n complex matrix and P is an orthogonal matrix,
C  consisting of a sequence of plane rotations determined by the
C  parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l'
C  and z = n when SIDE = 'R' or 'r' ):
C
C  When  DIRECT = 'F' or 'f'  ( Forward sequence ) then
C
C     P = P( z - 1 )*...*P( 2 )*P( 1 ),
C
C  and when DIRECT = 'B' or 'b'  ( Backward sequence ) then
C
C     P = P( 1 )*P( 2 )*...*P( z - 1 ),
C
C  where  P( k ) is a plane rotation matrix for the following planes:
C
C     when  PIVOT = 'V' or 'v'  ( Variable pivot ),
C        the plane ( k, k + 1 )
C
C     when  PIVOT = 'T' or 't'  ( Top pivot ),
C        the plane ( 1, k + 1 )
C
C     when  PIVOT = 'B' or 'b'  ( Bottom pivot ),
C        the plane ( k, z )
C
C  c( k ) and s( k )  must contain the  cosine and sine that define the
C  matrix  P( k ).  The two by two plane rotation part of the matrix
C  P( k ), R( k ), is assumed to be of the form
C
C     R( k ) = (  c( k )  s( k ) ).
C              ( -s( k )  c( k ) )
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          Specifies whether the plane rotation matrix P is applied to
C          A on the left or the right.
C          = 'L':  Left, compute A := P*A
C          = 'R':  Right, compute A:= A*P'
C
C  DIRECT  (input) CHARACTER*1
C          Specifies whether P is a forward or backward sequence of
C          plane rotations.
C          = 'F':  Forward, P = P( z - 1 )*...*P( 2 )*P( 1 )
C          = 'B':  Backward, P = P( 1 )*P( 2 )*...*P( z - 1 )
C
C  PIVOT   (input) CHARACTER*1
C          Specifies the plane for which P(k) is a plane rotation
C          matrix.
C          = 'V':  Variable pivot, the plane (k,k+1)
C          = 'T':  Top pivot, the plane (1,k+1)
C          = 'B':  Bottom pivot, the plane (k,z)
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  If m <= 1, an immediate
C          return is effected.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  If n <= 1, an
C          immediate return is effected.
C
C  C, S    (input) DOUBLE PRECISION arrays, dimension
C                  (M-1) if SIDE = 'L'
C                  (N-1) if SIDE = 'R'
C          c(k) and s(k) contain the cosine and sine that define the
C          matrix P(k).  The two by two plane rotation part of the
C          matrix P(k), R(k), is assumed to be of the form
C          R( k ) = (  c( k )  s( k ) ).
C                   ( -s( k )  c( k ) )
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          The m by n matrix A.  On exit, A is overwritten by P*A if
C          SIDE = 'R' or by A*P' if SIDE = 'L'.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, INFO, J
      Real*8   CTEMP, STEMP
      COMPLEX*16         TEMP
      LOGICAL            GLSame
C
C     Test the input parameters
C
      INFO = 0
      IF( .NOT.( GLSame( SIDE, 'L' ) .OR. GLSame( SIDE, 'R' ) ) ) THEN
         INFO = 1
      ELSE IF( .NOT.( GLSame( PIVOT, 'V' ) .OR. GLSame( PIVOT,
     $         'T' ) .OR. GLSame( PIVOT, 'B' ) ) ) THEN
         INFO = 2
      ELSE IF( .NOT.( GLSame( DIRECT, 'F' ) .OR. GLSame( 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) Call GLBErr('ZLASR',Info)
      If(M.eq.0.or.N.eq.0) RETURN
      IF( GLSame( SIDE, 'L' ) ) THEN
C
C        Form  P * A
C
         IF( GLSame( PIVOT, 'V' ) ) THEN
            IF( GLSame( 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( GLSame( 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( GLSame( PIVOT, 'T' ) ) THEN
            IF( GLSame( 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( GLSame( 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( GLSame( PIVOT, 'B' ) ) THEN
            IF( GLSame( 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( GLSame( 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( GLSame( SIDE, 'R' ) ) THEN
C
C        Form A * P'
C
         IF( GLSame( PIVOT, 'V' ) ) THEN
            IF( GLSame( 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( GLSame( 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( GLSame( PIVOT, 'T' ) ) THEN
            IF( GLSame( 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( GLSame( 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( GLSame( PIVOT, 'B' ) ) THEN
            IF( GLSame( 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( GLSame( 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
*Deck ZLASSQ
      Subroutine ZLASSQ( N, X, INCX, SCALE, SUMSQ )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK auxiliary routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     June 30, 1999
C
C     .. Scalar Arguments ..
      INTEGER            INCX, N
      Real*8   SCALE, SUMSQ
C     ..
C     .. Array Arguments ..
      COMPLEX*16         X( * )
C     ..
C
C  Purpose
C  =======
C
C  ZLASSQ returns the values scl and ssq such that
C
C     ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
C
C  where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is
C  assumed to be at least unity and the value of ssq will then satisfy
C
C     1.0 .le. ssq .le. ( sumsq + 2*n ).
C
C  scale is assumed to be non-negative and scl returns the value
C
C     scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
C            i
C
C  scale and sumsq must be supplied in SCALE and SUMSQ respectively.
C  SCALE and SUMSQ are overwritten by scl and ssq respectively.
C
C  The routine makes only one pass through the vector X.
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The number of elements to be used from the vector X.
C
C  X       (input) COMPLEX*16 array, dimension (N)
C          The vector x as described above.
C             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
C
C  INCX    (input) INTEGER
C          The increment between successive values of the vector X.
C          INCX > 0.
C
C  SCALE   (input/output) DOUBLE PRECISION
C          On entry, the value  scale  in the equation above.
C          On exit, SCALE is overwritten with the value  scl .
C
C  SUMSQ   (input/output) DOUBLE PRECISION
C          On entry, the value  sumsq  in the equation above.
C          On exit, SUMSQ is overwritten with the value  ssq .
C
C =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            IX
      Real*8   TEMP1
C     ..
C     .. Executable Statements ..
C
      IF( N.GT.0 ) THEN
         DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
            IF( GREAL( X( IX ) ).NE.ZERO ) THEN
               TEMP1 = ABS( GREAL( X( IX ) ) )
               IF( SCALE.LT.TEMP1 ) THEN
                  SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
                  SCALE = TEMP1
               ELSE
                  SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
               END IF
            END IF
            IF( GIMAG( X( IX ) ).NE.ZERO ) THEN
               TEMP1 = ABS( GIMAG( X( IX ) ) )
               IF( SCALE.LT.TEMP1 ) THEN
                  SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
                  SCALE = TEMP1
               ELSE
                  SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
               END IF
            END IF
   10    CONTINUE
      END IF
      RETURN
      END
*Deck ZPotF2
      SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  ZPOTF2 computes the Cholesky factorization of a complex Hermitian
C  positive definite matrix A.
C
C  The factorization has the form
C     A = U' * U ,  if UPLO = 'U', or
C     A = L  * L',  if UPLO = 'L',
C  where U is an upper triangular matrix and L is lower triangular.
C
C  This is the unblocked version of the algorithm, calling Level 2 BLAS.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies whether the upper or lower triangular part of the
C          Hermitian matrix A is stored.
C          = 'U':  Upper triangular
C          = 'L':  Lower triangular
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
C          n by n upper triangular part of A contains the upper
C          triangular part of the matrix A, and the strictly lower
C          triangular part of A is not referenced.  If UPLO = 'L', the
C          leading n by n lower triangular part of A contains the lower
C          triangular part of the matrix A, and the strictly upper
C          triangular part of A is not referenced.
C
C          On exit, if INFO = 0, the factor U or L from the Cholesky
C          factorization A = U'*U  or A = L*L'.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,N).
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -k, the k-th argument had an illegal value
C          > 0: if INFO = k, the leading minor of order k is not
C               positive definite, and the factorization could not be
C               completed.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      COMPLEX*16         CONE
      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J
      Real*8   AJJ
C     ..
C     .. External Functions ..
      LOGICAL            GLSAME
      COMPLEX*16         YDOTC
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      UPPER = GLSame( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.GLSame( 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) Call GLBErr('ZPotF2',Info)
      If(N.eq.0) RETURN
      IF( UPPER ) THEN
C
C        Compute the Cholesky factorization A = U'*U.
C
         DO 10 J = 1, N
C
C           Compute U(J,J) and test for non-positive-definiteness.
C
            AJJ = GREAL( A( J, J ) ) - YDotC( 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
C
C           Compute elements J+1:N of row J.
C
            IF( J.LT.N ) THEN
               CALL ZLACGV( J-1, A( 1, J ), 1 )
               CALL YGEMV( 'Transpose', J-1, N-J, -CONE, A( 1, J+1 ),
     $                     LDA, A( 1, J ), 1, CONE, A( J, J+1 ), LDA )
               CALL ZLACGV( J-1, A( 1, J ), 1 )
               CALL YDScal( N-J, ONE / AJJ, A( J, J+1 ), LDA )
            END IF
   10    CONTINUE
      ELSE
C
C        Compute the Cholesky factorization A = L*L'.
C
         DO 20 J = 1, N
C
C           Compute L(J,J) and test for non-positive-definiteness.
C
            AJJ = GREAL( A( J, J ) ) - YDotC( 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
C
C           Compute elements J+1:N of column J.
C
            IF( J.LT.N ) THEN
               CALL ZLACGV( J-1, A( J, 1 ), LDA )
               CALL YGEMV( 'No transpose', N-J, J-1, -CONE, A( J+1, 1 ),
     $                     LDA, A( J, 1 ), LDA, CONE, A( J+1, J ), 1 )
               CALL ZLACGV( J-1, A( J, 1 ), LDA )
               CALL YDScal( N-J, ONE / AJJ, A( J+1, J ), 1 )
            END IF
   20    CONTINUE
      END IF
      GO TO 40
C
   30 CONTINUE
      INFO = J
C
   40 CONTINUE
      RETURN
      END
*Deck ZPOTRF
      SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  ZPOTRF computes the Cholesky factorization of a complex Hermitian
C  positive definite matrix A.
C
C  The factorization has the form
C     A = U**H * U,  if UPLO = 'U', or
C     A = L  * L**H,  if UPLO = 'L',
C  where U is an upper triangular matrix and L is lower triangular.
C
C  This is the block version of the algorithm, calling Level 3 BLAS.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          = 'U':  Upper triangle of A is stored;
C          = 'L':  Lower triangle of A is stored.
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
C          N-by-N upper triangular part of A contains the upper
C          triangular part of the matrix A, and the strictly lower
C          triangular part of A is not referenced.  If UPLO = 'L', the
C          leading N-by-N lower triangular part of A contains the lower
C          triangular part of the matrix A, and the strictly upper
C          triangular part of A is not referenced.
C
C          On exit, if INFO = 0, the factor U or L from the Cholesky
C          factorization A = U**H*U or A = L*L**H.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,N).
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C          > 0:  if INFO = i, the leading minor of order i is not
C                positive definite, and the factorization could not be
C                completed.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ONE
      COMPLEX*16         CONE
      PARAMETER          ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, JB, NB
C     ..
C     .. External Functions ..
      LOGICAL            GLSAME
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      UPPER = GLSame( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.GLSame( 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) Call GLBErr('ZPOTR',Info)
      If(N.eq.0) RETURN
C
C     Determine the block size for this environment.
C
      NB = ILAENV( 1, 'ZPOTRF', UPLO, N, -1, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.N ) THEN
C
C        Use unblocked code.
C
         CALL ZPOTF2( UPLO, N, A, LDA, INFO )
      ELSE
C
C        Use blocked code.
C
         IF( UPPER ) THEN
C
C           Compute the Cholesky factorization A = U'*U.
C
            DO 10 J = 1, N, NB
C
C              Update and factorize the current diagonal block and test
C              for non-positive-definiteness.
C
               JB = MIN( NB, N-J+1 )
               CALL YHERK( 'Upper', 'Conjugate transpose', JB, J-1,
     $                     -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA )
               CALL ZPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
               IF( INFO.NE.0 )
     $            GO TO 30
               IF( J+JB.LE.N ) THEN
C
C                 Compute the current block row.
C
                  CALL YGEMM( 'Conjugate transpose', 'No transpose', JB,
     $                        N-J-JB+1, J-1, -CONE, A( 1, J ), LDA,
     $                        A( 1, J+JB ), LDA, CONE, A( J, J+JB ),
     $                        LDA )
                  CALL YTRSM( 'Left', 'Upper', 'Conjugate transpose',
     $                        'Non-unit', JB, N-J-JB+1, CONE, A( J, J ),
     $                        LDA, A( J, J+JB ), LDA )
               END IF
   10       CONTINUE
C
         ELSE
C
C           Compute the Cholesky factorization A = L*L'.
C
            DO 20 J = 1, N, NB
C
C              Update and factorize the current diagonal block and test
C              for non-positive-definiteness.
C
               JB = MIN( NB, N-J+1 )
               CALL YHERK( 'Lower', 'No transpose', JB, J-1, -ONE,
     $                     A( J, 1 ), LDA, ONE, A( J, J ), LDA )
               CALL ZPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
               IF( INFO.NE.0 )
     $            GO TO 30
               IF( J+JB.LE.N ) THEN
C
C                 Compute the current block column.
C
                  CALL YGEMM( 'No transpose', 'Conjugate transpose',
     $                        N-J-JB+1, JB, J-1, -CONE, A( J+JB, 1 ),
     $                        LDA, A( J, 1 ), LDA, CONE, A( J+JB, J ),
     $                        LDA )
                  CALL YTRSM( 'Right', 'Lower', 'Conjugate transpose',
     $                        'Non-unit', N-J-JB+1, JB, CONE, A( J, J ),
     $                        LDA, A( J+JB, J ), LDA )
               END IF
   20       CONTINUE
         END IF
      END IF
      GO TO 40
C
   30 CONTINUE
      INFO = INFO + J - 1
C
   40 CONTINUE
      RETURN
      END
*Deck ZSTEQR
      SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
      CHARACTER          COMPZ
      INTEGER            INFO, LDZ, N
      Real*8   D( * ), E( * ), WORK( * )
      COMPLEX*16         Z( LDZ, * )
      Common /LapCon/ Eps, SFMin, Base, TDLam, Rnd, EMin, RMin, EMax,
     $  RMax, Prec
C
C  Purpose
C  =======
C
C  ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
C  symmetric tridiagonal matrix using the implicit QL or QR method.
C  The eigenvectors of a full or band complex Hermitian matrix can also
C  be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
C  matrix to tridiagonal form.
C
C  Arguments
C  =========
C
C  COMPZ   (input) CHARACTER*1
C          = 'N':  Compute eigenvalues only.
C          = 'V':  Compute eigenvalues and eigenvectors of the original
C                  Hermitian matrix.  On entry, Z must contain the
C                  unitary matrix used to reduce the original matrix
C                  to tridiagonal form.
C          = 'I':  Compute eigenvalues and eigenvectors of the
C                  tridiagonal matrix.  Z is initialized to the identity
C                  matrix.
C
C  N       (input) INTEGER
C          The order of the matrix.  N >= 0.
C
C  D       (input/output) DOUBLE PRECISION array, dimension (N)
C          On entry, the diagonal elements of the tridiagonal matrix.
C          On exit, if INFO = 0, the eigenvalues in ascending order.
C
C  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
C          On entry, the (n-1) subdiagonal elements of the tridiagonal
C          matrix.
C          On exit, E has been destroyed.
C
C  Z       (input/output) COMPLEX*16 array, dimension (LDZ, N)
C          On entry, if  COMPZ = 'V', then Z contains the unitary
C          matrix used in the reduction to tridiagonal form.
C          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
C          orthonormal eigenvectors of the original Hermitian matrix,
C          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
C          of the symmetric tridiagonal matrix.
C          If COMPZ = 'N', then Z is not referenced.
C
C  LDZ     (input) INTEGER
C          The leading dimension of the array Z.  LDZ >= 1, and if
C          eigenvectors are desired, then  LDZ >= max(1,N).
C
C  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
C          If COMPZ = 'N', then WORK is not referenced.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C          > 0:  the algorithm has failed to find all the eigenvalues in
C                a total of 30*N iterations; if INFO = i, then i
C                elements of E have not converged to zero; on exit, D
C                and E contain the elements of a symmetric tridiagonal
C                matrix which is unitarily similar to the original
C                matrix.
C
C  =====================================================================
C
C     .. Parameters ..
      Real*8   ZERO, ONE, TWO, THREE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                   THREE = 3.0D0 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
     $                   CONE = ( 1.0D0, 0.0D0 ) )
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
     $                   LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
     $                   NM1, NMAXIT
      Real*8   ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
     $                   S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
      LOGICAL            GLSAME
      Real*8   DLANST, DLAPY2
C
C     Test the input parameters.
C
      INFO = 0
C
      IF( GLSame( COMPZ, 'N' ) ) THEN
         ICOMPZ = 0
      ELSE IF( GLSame( COMPZ, 'V' ) ) THEN
         ICOMPZ = 1
      ELSE IF( GLSame( 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) Call GLBErr('ZSTEQR',Info)
      If(N.eq.0) RETURN
      IF( N.EQ.1 ) THEN
         IF( ICOMPZ.EQ.2 )
     $      Z( 1, 1 ) = CONE
         RETURN
      END IF
C
C     Determine the unit roundoff and over/underflow thresholds.
C
      EPS2 = EPS**2
      SAFMIN = SFMin
      SAFMAX = ONE / SAFMIN
      SSFMAX = SQRT( SAFMAX ) / THREE
      SSFMIN = SQRT( SAFMIN ) / EPS2
C
C     Compute the eigenvalues and eigenvectors of the tridiagonal
C     matrix.
C
      IF( ICOMPZ.EQ.2 )
     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
C
      NMAXIT = N*MAXIT
      JTOT = 0
C
C     Determine where the matrix splits and choose QL or QR iteration
C     for each block, according to whether top or bottom diagonal
C     element is smaller.
C
      L1 = 1
      NM1 = N - 1
C
   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
C
   30 CONTINUE
      L = L1
      LSV = L
      LEND = M
      LENDSV = LEND
      L1 = M + 1
      IF( LEND.EQ.L )
     $   GO TO 10
C
C     Scale submatrix in rows and columns L to LEND
C
      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
C
C     Choose between QL and QR iteration
C
      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
         LEND = LSV
         L = LENDSV
      END IF
C
      IF( LEND.GT.L ) THEN
C
C        QL Iteration
C
C        Look for small subdiagonal element.
C
   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
C
         M = LEND
C
   60    CONTINUE
         IF( M.LT.LEND )
     $      E( M ) = ZERO
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 80
C
C        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
C        to compute its eigensystem.
C
         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 ZLASR( '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
C
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 140
         JTOT = JTOT + 1
C
C        Form shift.
C
         G = ( D( L+1 )-P ) / ( TWO*E( L ) )
         R = DLAPY2( G, ONE )
         G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
C
         S = ONE
         C = ONE
         P = ZERO
C
C        Inner loop
C
         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
C
C           If eigenvectors are desired, then save rotations.
C
            IF( ICOMPZ.GT.0 ) THEN
               WORK( I ) = C
               WORK( N-1+I ) = -S
            END IF
C
   70    CONTINUE
C
C        If eigenvectors are desired, then apply saved rotations.
C
         IF( ICOMPZ.GT.0 ) THEN
            MM = M - L + 1
            CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
     $                  Z( 1, L ), LDZ )
         END IF
C
         D( L ) = D( L ) - P
         E( L ) = G
         GO TO 40
C
C        Eigenvalue found.
C
   80    CONTINUE
         D( L ) = P
C
         L = L + 1
         IF( L.LE.LEND )
     $      GO TO 40
         GO TO 140
C
      ELSE
C
C        QR Iteration
C
C        Look for small superdiagonal element.
C
   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
C
         M = LEND
C
  110    CONTINUE
         IF( M.GT.LEND )
     $      E( M-1 ) = ZERO
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 130
C
C        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
C        to compute its eigensystem.
C
         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 ZLASR( '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
C
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 140
         JTOT = JTOT + 1
C
C        Form shift.
C
         G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
         R = DLAPY2( G, ONE )
         G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
C
         S = ONE
         C = ONE
         P = ZERO
C
C        Inner loop
C
         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
C
C           If eigenvectors are desired, then save rotations.
C
            IF( ICOMPZ.GT.0 ) THEN
               WORK( I ) = C
               WORK( N-1+I ) = S
            END IF
C
  120    CONTINUE
C
C        If eigenvectors are desired, then apply saved rotations.
C
         IF( ICOMPZ.GT.0 ) THEN
            MM = L - M + 1
            CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
     $                  Z( 1, M ), LDZ )
         END IF
C
         D( L ) = D( L ) - P
         E( LM1 ) = G
         GO TO 90
C
C        Eigenvalue found.
C
  130    CONTINUE
         D( L ) = P
C
         L = L - 1
         IF( L.GE.LEND )
     $      GO TO 90
         GO TO 140
C
      END IF
C
C     Undo scaling if necessary
C
  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
C
C     Check for no convergence to an eigenvalue after a total
C     of N*MAXIT iterations.
C
      IF( JTOT.EQ.NMAXIT ) THEN
         DO 150 I = 1, N - 1
            IF( E( I ).NE.ZERO )
     $         INFO = INFO + 1
  150    CONTINUE
         RETURN
      END IF
      GO TO 10
C
C     Order eigenvalues and eigenvectors.
C
  160 CONTINUE
      IF( ICOMPZ.EQ.0 ) THEN
C
C        Use Quick Sort
C
         CALL DLASRT( 'I', N, D, INFO )
C
      ELSE
C
C        Use Selection Sort to minimize swaps of eigenvectors
C
         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 YSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
            END IF
  180    CONTINUE
      END IF
      RETURN
      END
*Deck ZUNG2L
      SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  ZUNG2L generates an m by n complex matrix Q with orthonormal columns,
C  which is defined as the last n columns of a product of k elementary
C  reflectors of order m
C
C        Q  =  H(k) . . . H(2) H(1)
C
C  as returned by ZGEQLF.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q. M >= N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines the
C          matrix Q. N >= K >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the (n-k+i)-th column must contain the vector which
C          defines the elementary reflector H(i), for i = 1,2,...,k, as
C          returned by ZGEQLF in the last k columns of its array
C          argument A.
C          On exit, the m-by-n matrix Q.
C
C  LDA     (input) INTEGER
C          The first dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) COMPLEX*16 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by ZGEQLF.
C
C  WORK    (workspace) COMPLEX*16 array, dimension (N)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument has an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      INTEGER            I, II, J, L
C
C     Test the input arguments
C
      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) Call GLBErr('ZUNG2L',Info)
      If(N.le.0) RETURN
C
C     Initialise columns 1:n-k to columns of the unit matrix
C
      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
C
      DO 40 I = 1, K
         II = N - K + I
C
C        Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
C
         A( M-N+II, II ) = ONE
         CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
     $               LDA, WORK )
         CALL YScal( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
         A( M-N+II, II ) = ONE - TAU( I )
C
C        Set A(m-k+i+1:m,n-k+i) to zero
C
         DO 30 L = M - N + II + 1, M
            A( L, II ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
*Deck ZUNG2R
      SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  ZUNG2R generates an m by n complex matrix Q with orthonormal columns,
C  which is defined as the first n columns of a product of k elementary
C  reflectors of order m
C
C        Q  =  H(1) H(2) . . . H(k)
C
C  as returned by ZGEQRF.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q. M >= N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines the
C          matrix Q. N >= K >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the i-th column must contain the vector which
C          defines the elementary reflector H(i), for i = 1,2,...,k, as
C          returned by ZGEQRF in the first k columns of its array
C          argument A.
C          On exit, the m by n matrix Q.
C
C  LDA     (input) INTEGER
C          The first dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) COMPLEX*16 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by ZGEQRF.
C
C  WORK    (workspace) COMPLEX*16 array, dimension (N)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument has an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      INTEGER            I, J, L
C
C     Test the input arguments
C
      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) Call GLBErr('ZUNG2R',Info)
      If(N.le.0) RETURN
C
C     Initialise columns k+1:n to columns of the unit matrix
C
      DO 20 J = K + 1, N
         DO 10 L = 1, M
            A( L, J ) = ZERO
   10    CONTINUE
         A( J, J ) = ONE
   20 CONTINUE
C
      DO 40 I = K, 1, -1
C
C        Apply H(i) to A(i:m,i:n) from the left
C
         IF( I.LT.N ) THEN
            A( I, I ) = ONE
            CALL ZLARF( '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 YScal( M-I, -TAU( I ), A( I+1, I ), 1 )
         A( I, I ) = ONE - TAU( I )
C
C        Set A(1:i-1,i) to zero
C
         DO 30 L = 1, I - 1
            A( L, I ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
*Deck ZUngbr
      SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          VECT
      INTEGER            INFO, K, LDA, LWORK, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  ZUNGBR generates one of the complex unitary matrices Q or P**H
C  determined by ZGEBRD when reducing a complex matrix A to bidiagonal
C  form: A = Q * B * P**H.  Q and P**H are defined as products of
C  elementary reflectors H(i) or G(i) respectively.
C
C  If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
C  is of order M:
C  if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n
C  columns of Q, where m >= n >= k;
C  if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an
C  M-by-M matrix.
C
C  If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H
C  is of order N:
C  if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m
C  rows of P**H, where n >= m >= k;
C  if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as
C  an N-by-N matrix.
C
C  Arguments
C  =========
C
C  VECT    (input) CHARACTER*1
C          Specifies whether the matrix Q or the matrix P**H is
C          required, as defined in the transformation applied by ZGEBRD:
C          = 'Q':  generate Q;
C          = 'P':  generate P**H.
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q or P**H to be returned.
C          M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q or P**H to be returned.
C          N >= 0.
C          If VECT = 'Q', M >= N >= min(M,K);
C          if VECT = 'P', N >= M >= min(N,K).
C
C  K       (input) INTEGER
C          If VECT = 'Q', the number of columns in the original M-by-K
C          matrix reduced by ZGEBRD.
C          If VECT = 'P', the number of rows in the original K-by-N
C          matrix reduced by ZGEBRD.
C          K >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the vectors which define the elementary reflectors,
C          as returned by ZGEBRD.
C          On exit, the M-by-N matrix Q or P**H.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A. LDA >= M.
C
C  TAU     (input) COMPLEX*16 array, dimension
C                                (min(M,K)) if VECT = 'Q'
C                                (min(N,K)) if VECT = 'P'
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i) or G(i), which determines Q or P**H, as
C          returned by ZGEBRD in its array argument TAUQ or TAUP.
C
C  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK. LWORK >= max(1,min(M,N)).
C          For optimum performance LWORK >= min(M,N)*NB, where NB
C          is the optimal blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ZERO, ONE
      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      LOGICAL            WANTQ
      INTEGER            I, IINFO, J
      LOGICAL            GLSAME
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      WANTQ = GLSame( VECT, 'Q' )
      IF( .NOT.WANTQ .AND. .NOT.GLSame( 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, MIN( M, N ) ) ) THEN
         INFO = -9
      END IF
      If(Info.ne.0) Call GLBErr('ZUNGBR',Info)
C
C     Quick return if possible
C
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
C
      IF( WANTQ ) THEN
C
C        Form Q, determined by a call to ZGEBRD to reduce an m-by-k
C        matrix
C
         IF( M.GE.K ) THEN
C
C           If m >= k, assume m >= n >= k
C
            CALL ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
C
         ELSE
C
C           If m < k, assume m = n
C
C           Shift the vectors which define the elementary reflectors one
C           column to the right, and set the first row and column of Q
C           to those of the unit matrix
C
            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
C
C              Form Q(2:m,2:m)
C
               CALL ZUNGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
     $                      LWORK, IINFO )
            END IF
         END IF
      ELSE
C
C        Form P', determined by a call to ZGEBRD to reduce a k-by-n
C        matrix
C
         IF( K.LT.N ) THEN
C
C           If k < n, assume k <= m <= n
C
            CALL ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
C
         ELSE
C
C           If k >= n, assume m = n
C
C           Shift the vectors which define the elementary reflectors one
C           row downward, and set the first row and column of P' to
C           those of the unit matrix
C
            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
C
C              Form P'(2:n,2:n)
C
               CALL ZUNGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
     $                      LWORK, IINFO )
            END IF
         END IF
      END IF
      RETURN
      END
*Deck ZUNGL2
      SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,
C  which is defined as the first m rows of a product of k elementary
C  reflectors of order n
C
C        Q  =  H(k)' . . . H(2)' H(1)'
C
C  as returned by ZGELQF.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q. N >= M.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines the
C          matrix Q. M >= K >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the i-th row must contain the vector which defines
C          the elementary reflector H(i), for i = 1,2,...,k, as returned
C          by ZGELQF in the first k rows of its array argument A.
C          On exit, the m by n matrix Q.
C
C  LDA     (input) INTEGER
C          The first dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) COMPLEX*16 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by ZGELQF.
C
C  WORK    (workspace) COMPLEX*16 array, dimension (M)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument has an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ONE, ZERO, GCONJG
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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) Call GLBErr('ZUNGL2',Info)
      If(M.le.0) RETURN
      IF( K.LT.M ) THEN
C
C        Initialise rows k+1:m to rows of the unit matrix
C
         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
C
      DO 40 I = K, 1, -1
C
C        Apply H(i)' to A(i:m,i:n) from the right
C
         IF( I.LT.N ) THEN
            CALL ZLACGV( N-I, A( I, I+1 ), LDA )
            IF( I.LT.M ) THEN
               A( I, I ) = ONE
               CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
     $                     GCONJG( TAU( I ) ), A( I+1, I ), LDA, WORK )
            END IF
            CALL YScal( N-I, -TAU( I ), A( I, I+1 ), LDA )
            CALL ZLACGV( N-I, A( I, I+1 ), LDA )
         END IF
         A( I, I ) = ONE - GCONJG( TAU( I ) )
C
C        Set A(1:i-1,i) to zero
C
         DO 30 L = 1, I - 1
            A( I, L ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
*Deck ZUNGLQ
      SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, LWORK, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,
C  which is defined as the first M rows of a product of K elementary
C  reflectors of order N
C
C        Q  =  H(k)' . . . H(2)' H(1)'
C
C  as returned by ZGELQF.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q. N >= M.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines the
C          matrix Q. M >= K >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the i-th row must contain the vector which defines
C          the elementary reflector H(i), for i = 1,2,...,k, as returned
C          by ZGELQF in the first k rows of its array argument A.
C          On exit, the M-by-N matrix Q.
C
C  LDA     (input) INTEGER
C          The first dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) COMPLEX*16 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by ZGELQF.
C
C  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK. LWORK >= max(1,M).
C          For optimum performance LWORK >= M*NB, where NB is
C          the optimal blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit;
C          < 0:  if INFO = -i, the i-th argument has an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ZERO
      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB,
     $                   NBMIN, NX
      INTEGER            ILAENV
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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
      ELSE IF( LWORK.LT.MAX( 1, M ) ) THEN
         INFO = -8
      END IF
      If(Info.ne.0) Call GLBErr('ZUNGLQ',Info)
C
C     Quick return if possible
C
      IF( M.LE.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
C
C     Determine the block size.
C
      NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 )
      NBMIN = 2
      NX = 0
      IWS = M
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
C
C        Determine when to cross over from blocked to unblocked code.
C
         NX = MAX( 0, ILAENV( 3, 'ZUNGLQ', ' ', M, N, K, -1 ) )
         IF( NX.LT.K ) THEN
C
C           Determine if workspace is large enough for blocked code.
C
            LDWORK = M
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
C
C              Not enough workspace to use optimal NB:  reduce NB and
C              determine the minimum value of NB.
C
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'ZUNGLQ', ' ', M, N, K, -1 ) )
            END IF
         END IF
      END IF
C
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
C
C        Use blocked code after the last block.
C        The first kk rows are handled by the block method.
C
         KI = ( ( K-NX-1 ) / NB )*NB
         KK = MIN( K, KI+NB )
C
C        Set A(kk+1:m,1:kk) to zero.
C
         DO 20 J = 1, KK
            DO 10 I = KK + 1, M
               A( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
      ELSE
         KK = 0
      END IF
C
C     Use unblocked code for the last or only block.
C
      IF( KK.LT.M )
     $   CALL ZUNGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
     $                TAU( KK+1 ), WORK, IINFO )
C
      IF( KK.GT.0 ) THEN
C
C        Use blocked code
C
         DO 50 I = KI + 1, 1, -NB
            IB = MIN( NB, K-I+1 )
            IF( I+IB.LE.M ) THEN
C
C              Form the triangular factor of the block reflector
C              H = H(i) H(i+1) . . . H(i+ib-1)
C
               CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
     $                      LDA, TAU( I ), WORK, LDWORK )
C
C              Apply H' to A(i+ib:m,i:n) from the right
C
               CALL ZLARFB( 'Right', 'Conjugate 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
C
C           Apply H' to columns i:n of current block
C
            CALL ZUNGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
     $                   IINFO )
C
C           Set columns 1:i-1 of current block to zero
C
            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
*Deck ZUNGQR
      SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, LWORK, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,
C  which is defined as the first N columns of a product of K elementary
C  reflectors of order M
C
C        Q  =  H(1) H(2) . . . H(k)
C
C  as returned by ZGEQRF.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q. M >= N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines the
C          matrix Q. N >= K >= 0.
C
C  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C          On entry, the i-th column must contain the vector which
C          defines the elementary reflector H(i), for i = 1,2,...,k, as
C          returned by ZGEQRF in the first k columns of its array
C          argument A.
C          On exit, the M-by-N matrix Q.
C
C  LDA     (input) INTEGER
C          The first dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) COMPLEX*16 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by ZGEQRF.
C
C  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK. LWORK >= max(1,N).
C          For optimum performance LWORK >= N*NB, where NB is the
C          optimal blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument has an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ZERO
      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB,
     $                   NBMIN, NX
      INTEGER            ILAENV
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      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
      ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      If(Info.ne.0) Call GLBErr('ZUNGQR',Info)
C
C     Quick return if possible
C
      IF( N.LE.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
C
C     Determine the block size.
C
      NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 )
      NBMIN = 2
      NX = 0
      IWS = N
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
C
C        Determine when to cross over from blocked to unblocked code.
C
         NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) )
         IF( NX.LT.K ) THEN
C
C           Determine if workspace is large enough for blocked code.
C
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
C
C              Not enough workspace to use optimal NB:  reduce NB and
C              determine the minimum value of NB.
C
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) )
            END IF
         END IF
      END IF
C
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
C
C        Use blocked code after the last block.
C        The first kk columns are handled by the block method.
C
         KI = ( ( K-NX-1 ) / NB )*NB
         KK = MIN( K, KI+NB )
C
C        Set A(1:kk,kk+1:n) to zero.
C
         DO 20 J = KK + 1, N
            DO 10 I = 1, KK
               A( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
      ELSE
         KK = 0
      END IF
C
C     Use unblocked code for the last or only block.
C
      IF( KK.LT.N )
     $   CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
     $                TAU( KK+1 ), WORK, IINFO )
C
      IF( KK.GT.0 ) THEN
C
C        Use blocked code
C
         DO 50 I = KI + 1, 1, -NB
            IB = MIN( NB, K-I+1 )
            IF( I+IB.LE.N ) THEN
C
C              Form the triangular factor of the block reflector
C              H = H(i) H(i+1) . . . H(i+ib-1)
C
               CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB,
     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
C
C              Apply H to A(i:m,i+ib:n) from the left
C
               CALL ZLARFB( '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
C
C           Apply H to rows i:m of current block
C
            CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
     $                   IINFO )
C
C           Set rows 1:i-1 of current block to zero
C
            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
*Deck ZUNM2R
      SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  ZUNM2R overwrites the general complex m-by-n matrix C with
C
C        Q * C  if SIDE = 'L' and TRANS = 'N', or
C
C        Q'* C  if SIDE = 'L' and TRANS = 'C', or
C
C        C * Q  if SIDE = 'R' and TRANS = 'N', or
C
C        C * Q' if SIDE = 'R' and TRANS = 'C',
C
C  where Q is a complex unitary matrix defined as the product of k
C  elementary reflectors
C
C        Q = H(1) H(2) . . . H(k)
C
C  as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n
C  if SIDE = 'R'.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': apply Q or Q' from the Left
C          = 'R': apply Q or Q' from the Right
C
C  TRANS   (input) CHARACTER*1
C          = 'N': apply Q  (No transpose)
C          = 'C': apply Q' (Conjugate transpose)
C
C  M       (input) INTEGER
C          The number of rows of the matrix C. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C. N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines
C          the matrix Q.
C          If SIDE = 'L', M >= K >= 0;
C          if SIDE = 'R', N >= K >= 0.
C
C  A       (input) COMPLEX*16 array, dimension (LDA,K)
C          The i-th column must contain the vector which defines the
C          elementary reflector H(i), for i = 1,2,...,k, as returned by
C          ZGEQRF in the first k columns of its array argument A.
C          A is modified by the routine but restored on exit.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.
C          If SIDE = 'L', LDA >= max(1,M);
C          if SIDE = 'R', LDA >= max(1,N).
C
C  TAU     (input) COMPLEX*16 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by ZGEQRF.
C
C  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
C          On entry, the m-by-n matrix C.
C          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace) COMPLEX*16 array, dimension
C                                   (N) if SIDE = 'L',
C                                   (M) if SIDE = 'R'
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
      COMPLEX*16         AII, TAUI, GCONJG
      LOGICAL            GLSAME
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      LEFT = GLSame( SIDE, 'L' )
      NOTRAN = GLSame( TRANS, 'N' )
C
C     NQ is the order of Q
C
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.GLSame( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.GLSame( TRANS, 'C' ) ) 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) Call GLBErr('ZUNM2R',Info)
      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
C
      IF( LEFT ) THEN
         NI = N
         JC = 1
      ELSE
         MI = M
         IC = 1
      END IF
C
      DO 10 I = I1, I2, I3
         IF( LEFT ) THEN
C
C           H(i) or H(i)' is applied to C(i:m,1:n)
C
            MI = M - I + 1
            IC = I
         ELSE
C
C           H(i) or H(i)' is applied to C(1:m,i:n)
C
            NI = N - I + 1
            JC = I
         END IF
C
C        Apply H(i) or H(i)'
C
         IF( NOTRAN ) THEN
            TAUI = TAU( I )
         ELSE
            TAUI = GCONJG( TAU( I ) )
         END IF
         AII = A( I, I )
         A( I, I ) = ONE
         CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC,
     $               WORK )
         A( I, I ) = AII
   10 CONTINUE
      RETURN
      END
*Deck ZUNMBR
      SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
     $                   LDC, WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS, VECT
      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ),
     $                   WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C
C  with
C                  SIDE = 'L'     SIDE = 'R'
C  TRANS = 'N':      Q * C          C * Q
C  TRANS = 'C':      Q**H * C       C * Q**H
C
C  If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C
C  with
C                  SIDE = 'L'     SIDE = 'R'
C  TRANS = 'N':      P * C          C * P
C  TRANS = 'C':      P**H * C       C * P**H
C
C  Here Q and P**H are the unitary matrices determined by ZGEBRD when
C  reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q
C  and P**H are defined as products of elementary reflectors H(i) and
C  G(i) respectively.
C
C  Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
C  order of the unitary matrix Q or P**H that is applied.
C
C  If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
C  if nq >= k, Q = H(1) H(2) . . . H(k);
C  if nq < k, Q = H(1) H(2) . . . H(nq-1).
C
C  If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
C  if k < nq, P = G(1) G(2) . . . G(k);
C  if k >= nq, P = G(1) G(2) . . . G(nq-1).
C
C  Arguments
C  =========
C
C  VECT    (input) CHARACTER*1
C          = 'Q': apply Q or Q**H;
C          = 'P': apply P or P**H.
C
C  SIDE    (input) CHARACTER*1
C          = 'L': apply Q, Q**H, P or P**H from the Left;
C          = 'R': apply Q, Q**H, P or P**H from the Right.
C
C  TRANS   (input) CHARACTER*1
C          = 'N':  No transpose, apply Q or P;
C          = 'C':  Conjugate transpose, apply Q**H or P**H.
C
C  M       (input) INTEGER
C          The number of rows of the matrix C. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C. N >= 0.
C
C  K       (input) INTEGER
C          If VECT = 'Q', the number of columns in the original
C          matrix reduced by ZGEBRD.
C          If VECT = 'P', the number of rows in the original
C          matrix reduced by ZGEBRD.
C          K >= 0.
C
C  A       (input) COMPLEX*16 array, dimension
C                                (LDA,min(nq,K)) if VECT = 'Q'
C                                (LDA,nq)        if VECT = 'P'
C          The vectors which define the elementary reflectors H(i) and
C          G(i), whose products determine the matrices Q and P, as
C          returned by ZGEBRD.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.
C          If VECT = 'Q', LDA >= max(1,nq);
C          if VECT = 'P', LDA >= max(1,min(nq,K)).
C
C  TAU     (input) COMPLEX*16 array, dimension (min(nq,K))
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i) or G(i) which determines Q or P, as returned
C          by ZGEBRD in the array argument TAUQ or TAUP.
C
C  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
C          On entry, the M-by-N matrix C.
C          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q
C          or P*C or P**H*C or C*P or C*P**H.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK.
C          If SIDE = 'L', LWORK >= max(1,N);
C          if SIDE = 'R', LWORK >= max(1,M).
C          For optimum performance LWORK >= N*NB if SIDE = 'L', and
C          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
C          blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Local Scalars ..
      LOGICAL            APPLYQ, LEFT, NOTRAN
      CHARACTER          TRANST
      INTEGER            I1, I2, IINFO, MI, NI, NQ, NW
      LOGICAL            GLSAME
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      APPLYQ = GLSame( VECT, 'Q' )
      LEFT = GLSame( SIDE, 'L' )
      NOTRAN = GLSame( TRANS, 'N' )
C
C     NQ is the order of Q or P and NW is the minimum dimension of WORK
C
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.APPLYQ .AND. .NOT.GLSame( VECT, 'P' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LEFT .AND. .NOT.GLSame( SIDE, 'R' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOTRAN .AND. .NOT.GLSame( TRANS, 'C' ) ) 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 ) ) THEN
         INFO = -13
      END IF
      If(Info.ne.0) Call GLBErr('ZUNMBR',Info)
      WORK( 1 ) = 1
      If(M.eq.0.or.N.eq.0) RETURN
      IF( APPLYQ ) THEN
C
C        Apply Q
C
         IF( NQ.GE.K ) THEN
C
C           Q was determined by a call to ZGEBRD with nq >= k
C
            CALL ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, LWORK, IINFO )
         ELSE IF( NQ.GT.1 ) THEN
C
C           Q was determined by a call to ZGEBRD with nq < k
C
            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 ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
     $                   C( I1, I2 ), LDC, WORK, LWORK, IINFO )
         END IF
      ELSE
C
C        Apply P
C
         IF( NOTRAN ) THEN
            TRANST = 'C'
         ELSE
            TRANST = 'N'
         END IF
         IF( NQ.GT.K ) THEN
C
C           P was determined by a call to ZGEBRD with nq > k
C
            CALL ZUNMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, LWORK, IINFO )
         ELSE IF( NQ.GT.1 ) THEN
C
C           P was determined by a call to ZGEBRD with nq <= k
C
            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 ZUNMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA,
     $                   TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO )
         END IF
      END IF
      RETURN
      END
*Deck ZUNML2
      SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  ZUNML2 overwrites the general complex m-by-n matrix C with
C
C        Q * C  if SIDE = 'L' and TRANS = 'N', or
C
C        Q'* C  if SIDE = 'L' and TRANS = 'C', or
C
C        C * Q  if SIDE = 'R' and TRANS = 'N', or
C
C        C * Q' if SIDE = 'R' and TRANS = 'C',
C
C  where Q is a complex unitary matrix defined as the product of k
C  elementary reflectors
C
C        Q = H(k)' . . . H(2)' H(1)'
C
C  as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n
C  if SIDE = 'R'.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': apply Q or Q' from the Left
C          = 'R': apply Q or Q' from the Right
C
C  TRANS   (input) CHARACTER*1
C          = 'N': apply Q  (No transpose)
C          = 'C': apply Q' (Conjugate transpose)
C
C  M       (input) INTEGER
C          The number of rows of the matrix C. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C. N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines
C          the matrix Q.
C          If SIDE = 'L', M >= K >= 0;
C          if SIDE = 'R', N >= K >= 0.
C
C  A       (input) COMPLEX*16 array, dimension
C                               (LDA,M) if SIDE = 'L',
C                               (LDA,N) if SIDE = 'R'
C          The i-th row must contain the vector which defines the
C          elementary reflector H(i), for i = 1,2,...,k, as returned by
C          ZGELQF in the first k rows of its array argument A.
C          A is modified by the routine but restored on exit.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A. LDA >= max(1,K).
C
C  TAU     (input) COMPLEX*16 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by ZGELQF.
C
C  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
C          On entry, the m-by-n matrix C.
C          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace) COMPLEX*16 array, dimension
C                                   (N) if SIDE = 'L',
C                                   (M) if SIDE = 'R'
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         ONE, GCONJG
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
      COMPLEX*16         AII, TAUI
      LOGICAL            GLSAME
C
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      LEFT = GLSame( SIDE, 'L' )
      NOTRAN = GLSame( TRANS, 'N' )
C
C     NQ is the order of Q
C
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.GLSame( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.GLSame( TRANS, 'C' ) ) 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) Call GLBErr('ZUnML2',Info)
      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
C
      IF( LEFT ) THEN
         NI = N
         JC = 1
      ELSE
         MI = M
         IC = 1
      END IF
C
      DO 10 I = I1, I2, I3
         IF( LEFT ) THEN
C
C           H(i) or H(i)' is applied to C(i:m,1:n)
C
            MI = M - I + 1
            IC = I
         ELSE
C
C           H(i) or H(i)' is applied to C(1:m,i:n)
C
            NI = N - I + 1
            JC = I
         END IF
C
C        Apply H(i) or H(i)'
C
         IF( NOTRAN ) THEN
            TAUI = GCONJG( TAU( I ) )
         ELSE
            TAUI = TAU( I )
         END IF
         IF( I.LT.NQ )
     $      CALL ZLACGV( NQ-I, A( I, I+1 ), LDA )
         AII = A( I, I )
         A( I, I ) = ONE
         CALL ZLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ),
     $               LDC, WORK )
         A( I, I ) = AII
         IF( I.LT.NQ )
     $      CALL ZLACGV( NQ-I, A( I, I+1 ), LDA )
   10 CONTINUE
      RETURN
      END
*Deck ZUNMLQ
      SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ),
     $                   WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  ZUNMLQ overwrites the general complex M-by-N matrix C with
C
C                  SIDE = 'L'     SIDE = 'R'
C  TRANS = 'N':      Q * C          C * Q
C  TRANS = 'C':      Q**H * C       C * Q**H
C
C  where Q is a complex unitary matrix defined as the product of k
C  elementary reflectors
C
C        Q = H(k)' . . . H(2)' H(1)'
C
C  as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N
C  if SIDE = 'R'.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': apply Q or Q**H from the Left;
C          = 'R': apply Q or Q**H from the Right.
C
C  TRANS   (input) CHARACTER*1
C          = 'N':  No transpose, apply Q;
C          = 'C':  Conjugate transpose, apply Q**H.
C
C  M       (input) INTEGER
C          The number of rows of the matrix C. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C. N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines
C          the matrix Q.
C          If SIDE = 'L', M >= K >= 0;
C          if SIDE = 'R', N >= K >= 0.
C
C  A       (input) COMPLEX*16 array, dimension
C                               (LDA,M) if SIDE = 'L',
C                               (LDA,N) if SIDE = 'R'
C          The i-th row must contain the vector which defines the
C          elementary reflector H(i), for i = 1,2,...,k, as returned by
C          ZGELQF in the first k rows of its array argument A.
C          A is modified by the routine but restored on exit.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A. LDA >= max(1,K).
C
C  TAU     (input) COMPLEX*16 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by ZGELQF.
C
C  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
C          On entry, the M-by-N matrix C.
C          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK.
C          If SIDE = 'L', LWORK >= max(1,N);
C          if SIDE = 'R', LWORK >= max(1,M).
C          For optimum performance LWORK >= N*NB if SIDE 'L', and
C          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
C          blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      INTEGER            NBMAX, LDT
      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
C     ..
C     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      CHARACTER          TRANST
      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
     $                   MI, NB, NBMIN, NI, NQ, NW
C     ..
C     .. Local Arrays ..
      COMPLEX*16         T( LDT, NBMAX )
C     ..
C     .. External Functions ..
      LOGICAL            GLSAME
      INTEGER            ILAENV
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      LEFT = GLSame( SIDE, 'L' )
      NOTRAN = GLSame( TRANS, 'N' )
C
C     NQ is the order of Q and NW is the minimum dimension of WORK
C
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.LEFT .AND. .NOT.GLSame( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.GLSame( TRANS, 'C' ) ) 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 ) ) THEN
         INFO = -12
      END IF
      If(Info.ne.0) Call GLBErr('ZUNMLQ',Info)
C
C     Quick return if possible
C
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
C
C     Determine the block size.  NB may be at most NBMAX, where NBMAX
C     is used to define the local array T.
C
      NB = MIN( NBMAX, ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N, K,
     $     -1 ) )
      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, 'ZUNMLQ', SIDE // TRANS, M, N, K,
     $              -1 ) )
         END IF
      ELSE
         IWS = NW
      END IF
C
      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
C
C        Use unblocked code
C
         CALL ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
     $                IINFO )
      ELSE
C
C        Use blocked code
C
         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
C
         IF( LEFT ) THEN
            NI = N
            JC = 1
         ELSE
            MI = M
            IC = 1
         END IF
C
         IF( NOTRAN ) THEN
            TRANST = 'C'
         ELSE
            TRANST = 'N'
         END IF
C
         DO 10 I = I1, I2, I3
            IB = MIN( NB, K-I+1 )
C
C           Form the triangular factor of the block reflector
C           H = H(i) H(i+1) . . . H(i+ib-1)
C
            CALL ZLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ),
     $                   LDA, TAU( I ), T, LDT )
            IF( LEFT ) THEN
C
C              H or H' is applied to C(i:m,1:n)
C
               MI = M - I + 1
               IC = I
            ELSE
C
C              H or H' is applied to C(1:m,i:n)
C
               NI = N - I + 1
               JC = I
            END IF
C
C           Apply H or H'
C
            CALL ZLARFB( 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 ) = IWS
      RETURN
      END
*Deck ZUNMQR
      SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, LWORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 2.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ),
     $                   WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  ZUNMQR overwrites the general complex M-by-N matrix C with
C
C                  SIDE = 'L'     SIDE = 'R'
C  TRANS = 'N':      Q * C          C * Q
C  TRANS = 'C':      Q**H * C       C * Q**H
C
C  where Q is a complex unitary matrix defined as the product of k
C  elementary reflectors
C
C        Q = H(1) H(2) . . . H(k)
C
C  as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N
C  if SIDE = 'R'.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': apply Q or Q**H from the Left;
C          = 'R': apply Q or Q**H from the Right.
C
C  TRANS   (input) CHARACTER*1
C          = 'N':  No transpose, apply Q;
C          = 'C':  Conjugate transpose, apply Q**H.
C
C  M       (input) INTEGER
C          The number of rows of the matrix C. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C. N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines
C          the matrix Q.
C          If SIDE = 'L', M >= K >= 0;
C          if SIDE = 'R', N >= K >= 0.
C
C  A       (input) COMPLEX*16 array, dimension (LDA,K)
C          The i-th column must contain the vector which defines the
C          elementary reflector H(i), for i = 1,2,...,k, as returned by
C          ZGEQRF in the first k columns of its array argument A.
C          A is modified by the routine but restored on exit.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.
C          If SIDE = 'L', LDA >= max(1,M);
C          if SIDE = 'R', LDA >= max(1,N).
C
C  TAU     (input) COMPLEX*16 array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by ZGEQRF.
C
C  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
C          On entry, the M-by-N matrix C.
C          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
C          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK.
C          If SIDE = 'L', LWORK >= max(1,N);
C          if SIDE = 'R', LWORK >= max(1,M).
C          For optimum performance LWORK >= N*NB if SIDE = 'L', and
C          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
C          blocksize.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      INTEGER            NBMAX, LDT
      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
C     ..
C     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
     $                   MI, NB, NBMIN, NI, NQ, NW
C     ..
C     .. Local Arrays ..
      COMPLEX*16         T( LDT, NBMAX )
C     ..
C     .. External Functions ..
      LOGICAL            GLSAME
      INTEGER            ILAENV
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      LEFT = GLSame( SIDE, 'L' )
      NOTRAN = GLSame( TRANS, 'N' )
C
C     NQ is the order of Q and NW is the minimum dimension of WORK
C
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.LEFT .AND. .NOT.GLSame( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.GLSame( TRANS, 'C' ) ) 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 ) ) THEN
         INFO = -12
      END IF
      If(Info.ne.0) Call GLBErr('ZUNMQR',Info)
C
C     Quick return if possible
C
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
C
C     Determine the block size.  NB may be at most NBMAX, where NBMAX
C     is used to define the local array T.
C
      NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K,
     $     -1 ) )
      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, 'ZUNMQR', SIDE // TRANS, M, N, K,
     $              -1 ) )
         END IF
      ELSE
         IWS = NW
      END IF
C
      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
C
C        Use unblocked code
C
         CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
     $                IINFO )
      ELSE
C
C        Use blocked code
C
         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
C
         IF( LEFT ) THEN
            NI = N
            JC = 1
         ELSE
            MI = M
            IC = 1
         END IF
C
         DO 10 I = I1, I2, I3
            IB = MIN( NB, K-I+1 )
C
C           Form the triangular factor of the block reflector
C           H = H(i) H(i+1) . . . H(i+ib-1)
C
            CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
     $                   LDA, TAU( I ), T, LDT )
            IF( LEFT ) THEN
C
C              H or H' is applied to C(i:m,1:n)
C
               MI = M - I + 1
               IC = I
            ELSE
C
C              H or H' is applied to C(1:m,i:n)
C
               NI = N - I + 1
               JC = I
            END IF
C
C           Apply H or H'
C
            CALL ZLARFB( 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 ) = IWS
      RETURN
      END
*Deck ZUPGTR
      SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
      Implicit Real*8(A-H,O-Z)
C
C  -- LAPACK routine (version 3.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     September 30, 1994
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDQ, N
C     ..
C     .. Array Arguments ..
      COMPLEX*16         AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  ZUPGTR generates a complex unitary matrix Q which is defined as the
C  product of n-1 elementary reflectors H(i) of order n, as returned by
C  ZHPTRD using packed storage:
C
C  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
C
C  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          = 'U': Upper triangular packed storage used in previous
C                 call to ZHPTRD;
C          = 'L': Lower triangular packed storage used in previous
C                 call to ZHPTRD.
C
C  N       (input) INTEGER
C          The order of the matrix Q. N >= 0.
C
C  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
C          The vectors which define the elementary reflectors, as
C          returned by ZHPTRD.
C
C  TAU     (input) COMPLEX*16 array, dimension (N-1)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by ZHPTRD.
C
C  Q       (output) COMPLEX*16 array, dimension (LDQ,N)
C          The N-by-N unitary matrix Q.
C
C  LDQ     (input) INTEGER
C          The leading dimension of the array Q. LDQ >= max(1,N).
C
C  WORK    (workspace) COMPLEX*16 array, dimension (N-1)
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0:  if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IINFO, IJ, J
      LOGICAL            GLSame
C
C     Test the input arguments
C
      INFO = 0
      UPPER = GLSame( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.GLSame( 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) Call GLBErr('ZUPGTR',Info)
      If(N.eq.0) RETURN
      IF( UPPER ) THEN
C
C        Q was determined by a call to ZHPTRD with UPLO = 'U'
C
C        Unpack the vectors which define the elementary reflectors and
C        set the last row and column of Q equal to those of the unit
C        matrix
C
         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 ) = CZERO
   20    CONTINUE
         DO 30 I = 1, N - 1
            Q( I, N ) = CZERO
   30    CONTINUE
         Q( N, N ) = CONE
C
C        Generate Q(1:n-1,1:n-1)
C
         CALL ZUNG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
C
      ELSE
C
C        Q was determined by a call to ZHPTRD with UPLO = 'L'.
C
C        Unpack the vectors which define the elementary reflectors and
C        set the first row and column of Q equal to those of the unit
C        matrix
C
         Q( 1, 1 ) = CONE
         DO 40 I = 2, N
            Q( I, 1 ) = CZERO
   40    CONTINUE
         IJ = 3
         DO 60 J = 2, N
            Q( 1, J ) = CZERO
            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
C
C           Generate Q(2:n,2:n)
C
            CALL ZUNG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
     $                   IINFO )
         END IF
      END IF
      RETURN
      END
