INTEGER FUNCTION IZMAX1( N, CX, INCX ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N * .. * .. Array Arguments .. COMPLEX*16 CX( * ) * .. * * Purpose * ======= * * IZMAX1 finds the index of the element whose real part has maximum * absolute value. * * Based on IZAMAX from Level 1 BLAS. * The change is to use the 'genuine' absolute value. * * Contributed by Nick Higham for use with ZLACON. * * Arguments * ========= * * N (input) INTEGER * The number of elements in the vector CX. * * CX (input) COMPLEX*16 array, dimension (N) * The vector whose elements will be summed. * * INCX (input) INTEGER * The spacing between successive values of CX. INCX >= 1. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IX DOUBLE PRECISION SMAX COMPLEX*16 ZDUM * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. * * NEXT LINE IS THE ONLY MODIFICATION. CABS1( ZDUM ) = ABS( ZDUM ) * .. * .. Executable Statements .. * IZMAX1 = 0 IF( N.LT.1 ) $ RETURN IZMAX1 = 1 IF( N.EQ.1 ) $ RETURN IF( INCX.EQ.1 ) $ GO TO 30 * * CODE FOR INCREMENT NOT EQUAL TO 1 * IX = 1 SMAX = CABS1( CX( 1 ) ) IX = IX + INCX DO 20 I = 2, N IF( CABS1( CX( IX ) ).LE.SMAX ) $ GO TO 10 IZMAX1 = I SMAX = CABS1( CX( IX ) ) 10 CONTINUE IX = IX + INCX 20 CONTINUE RETURN * * CODE FOR INCREMENT EQUAL TO 1 * 30 CONTINUE SMAX = CABS1( CX( 1 ) ) DO 40 I = 2, N IF( CABS1( CX( I ) ).LE.SMAX ) $ GO TO 40 IZMAX1 = I SMAX = CABS1( CX( I ) ) 40 CONTINUE RETURN * * End of IZMAX1 * END SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, RWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), RWORK( * ) COMPLEX*16 C( LDC, * ), U( LDU, * ), VT( LDVT, * ) * .. * * Purpose * ======= * * ZBDSQR computes the singular values and, optionally, the right and/or * left singular vectors from the singular value decomposition (SVD) of * a real N-by-N (upper or lower) bidiagonal matrix B using the implicit * zero-shift QR algorithm. The SVD of B has the form * * B = Q * S * P**H * * where S is the diagonal matrix of singular values, Q is an orthogonal * matrix of left singular vectors, and P is an orthogonal matrix of * right singular vectors. If left singular vectors are requested, this * subroutine actually returns U*Q instead of Q, and, if right singular * vectors are requested, this subroutine returns P**H*VT instead of * P**H, for given complex input matrices U and VT. When U and VT are * the unitary matrices that reduce a general matrix A to bidiagonal * form: A = U*B*VT, as computed by ZGEBRD, then * * A = (U*Q) * S * (P**H*VT) * * is the SVD of A. Optionally, the subroutine may also compute Q**H*C * for a given complex input matrix C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, * LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, * no. 5, pp. 873-912, Sept 1990) and * "Accurate singular values and differential qd algorithms," by * B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics * Department, University of California at Berkeley, July 1992 * for a detailed description of the algorithm. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': B is upper bidiagonal; * = 'L': B is lower bidiagonal. * * N (input) INTEGER * The order of the matrix B. N >= 0. * * NCVT (input) INTEGER * The number of columns of the matrix VT. NCVT >= 0. * * NRU (input) INTEGER * The number of rows of the matrix U. NRU >= 0. * * NCC (input) INTEGER * The number of columns of the matrix C. NCC >= 0. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the n diagonal elements of the bidiagonal matrix B. * On exit, if INFO=0, the singular values of B in decreasing * order. * * E (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, the N-1 offdiagonal elements of the bidiagonal * matrix B. * On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E * will contain the diagonal and superdiagonal elements of a * bidiagonal matrix orthogonally equivalent to the one given * as input. * * VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. * On exit, VT is overwritten by P**H * VT. * Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. * LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. * * U (input/output) COMPLEX*16 array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. * Not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) COMPLEX*16 array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. * On exit, C is overwritten by Q**H * C. * Not referenced if NCC = 0. * * LDC (input) INTEGER * The leading dimension of the array C. * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) * if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise * * INFO (output) INTEGER * = 0: successful exit * < 0: If INFO = -i, the i-th argument had an illegal value * > 0: the algorithm did not converge; D and E contain the * elements of a bidiagonal matrix which is orthogonally * similar to the input matrix B; if INFO = i, i * elements of E have not converged to zero. * * Internal Parameters * =================== * * TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) * TOLMUL controls the convergence criterion of the QR loop. * If it is positive, TOLMUL*EPS is the desired relative * precision in the computed singular values. * If it is negative, abs(TOLMUL*EPS*sigma_max) is the * desired absolute accuracy in the computed singular * values (corresponds to relative accuracy * abs(TOLMUL*EPS) in the largest singular value. * abs(TOLMUL) should be between 1 and 1/EPS, and preferably * between 10 (for fast convergence) and .1/EPS * (for there to be some accuracy in the results). * Default is to lose at either one eighth or 2 of the * available decimal digits in each computed singular value * (whichever is smaller). * * MAXITR INTEGER, default = 6 * MAXITR controls the maximum number of passes of the * algorithm through its inner loop. The algorithms stops * (and so fails to converge) if the number of passes * through the inner loop exceeds MAXITR*N**2. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION NEGONE PARAMETER ( NEGONE = -1.0D0 ) DOUBLE PRECISION HNDRTH PARAMETER ( HNDRTH = 0.01D0 ) DOUBLE PRECISION TEN PARAMETER ( TEN = 10.0D0 ) DOUBLE PRECISION HNDRD PARAMETER ( HNDRD = 100.0D0 ) DOUBLE PRECISION MEIGTH PARAMETER ( MEIGTH = -0.125D0 ) INTEGER MAXITR PARAMETER ( MAXITR = 6 ) * .. * .. Local Scalars .. LOGICAL LOWER, ROTATE INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, $ NM12, NM13, OLDLL, OLDM DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, $ SN, THRESH, TOL, TOLMUL, UNFL * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLARTG, DLAS2, DLASQ1, DLASV2, XERBLA, ZDROT, $ ZDSCAL, ZLASR, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 LOWER = LSAME( UPLO, 'L' ) IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NCVT.LT.0 ) THEN INFO = -3 ELSE IF( NRU.LT.0 ) THEN INFO = -4 ELSE IF( NCC.LT.0 ) THEN INFO = -5 ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN INFO = -9 ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN INFO = -11 ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZBDSQR', -INFO ) RETURN END IF IF( N.EQ.0 ) $ RETURN IF( N.EQ.1 ) $ GO TO 160 * * ROTATE is true if any singular vectors desired, false otherwise * ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) * * If no singular vectors desired, use qd algorithm * IF( .NOT.ROTATE ) THEN CALL DLASQ1( N, D, E, RWORK, INFO ) RETURN END IF * NM1 = N - 1 NM12 = NM1 + NM1 NM13 = NM12 + NM1 IDIR = 0 * * Get machine constants * EPS = DLAMCH( 'Epsilon' ) UNFL = DLAMCH( 'Safe minimum' ) * * If matrix lower bidiagonal, rotate to be upper bidiagonal * by applying Givens rotations on the left * IF( LOWER ) THEN DO 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 * * Update singular vectors if desired * 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 * * Compute singular values to relative accuracy TOL * (By setting TOL to be negative, algorithm will compute * singular values to absolute accuracy ABS(TOL)*norm(input matrix)) * TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) ) TOL = TOLMUL*EPS * * Compute approximate maximum, minimum singular values * SMAX = ZERO DO 20 I = 1, N SMAX = MAX( SMAX, ABS( D( I ) ) ) 20 CONTINUE DO 30 I = 1, N - 1 SMAX = MAX( SMAX, ABS( E( I ) ) ) 30 CONTINUE SMINL = ZERO IF( TOL.GE.ZERO ) THEN * * Relative accuracy desired * SMINOA = ABS( D( 1 ) ) IF( SMINOA.EQ.ZERO ) $ GO TO 50 MU = SMINOA DO 40 I = 2, N MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) SMINOA = MIN( SMINOA, MU ) IF( SMINOA.EQ.ZERO ) $ GO TO 50 40 CONTINUE 50 CONTINUE SMINOA = SMINOA / SQRT( DBLE( N ) ) THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) ELSE * * Absolute accuracy desired * THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL ) END IF * * Prepare for main iteration loop for the singular values * (MAXIT is the maximum number of passes through the inner * loop permitted before nonconvergence signalled.) * MAXIT = MAXITR*N*N ITER = 0 OLDLL = -1 OLDM = -1 * * M points to last element of unconverged part of matrix * M = N * * Begin main iteration loop * 60 CONTINUE * * Check for convergence or exceeding iteration count * IF( M.LE.1 ) $ GO TO 160 IF( ITER.GT.MAXIT ) $ GO TO 200 * * Find diagonal block of matrix to work on * IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) $ D( M ) = ZERO SMAX = ABS( D( M ) ) SMIN = SMAX DO 70 LLL = 1, M - 1 LL = M - LLL ABSS = ABS( D( LL ) ) ABSE = ABS( E( LL ) ) IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) $ D( LL ) = ZERO IF( ABSE.LE.THRESH ) $ GO TO 80 SMIN = MIN( SMIN, ABSS ) SMAX = MAX( SMAX, ABSS, ABSE ) 70 CONTINUE LL = 0 GO TO 90 80 CONTINUE E( LL ) = ZERO * * Matrix splits since E(LL) = 0 * IF( LL.EQ.M-1 ) THEN * * Convergence of bottom singular value, return to top of loop * M = M - 1 GO TO 60 END IF 90 CONTINUE LL = LL + 1 * * E(LL) through E(M-1) are nonzero, E(LL-1) is zero * IF( LL.EQ.M-1 ) THEN * * 2 by 2 block, handle separately * CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, $ COSR, SINL, COSL ) D( M-1 ) = SIGMX E( M-1 ) = ZERO D( M ) = SIGMN * * Compute singular vectors, if desired * IF( NCVT.GT.0 ) $ CALL 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 60 END IF * * If working on new submatrix, choose shift direction * (from larger end diagonal element towards smaller) * IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN * * Chase bulge from top (big end) to bottom (small end) * IDIR = 1 ELSE * * Chase bulge from bottom (big end) to top (small end) * IDIR = 2 END IF END IF * * Apply convergence tests * IF( IDIR.EQ.1 ) THEN * * Run convergence test in forward direction * First apply standard test to bottom of matrix * IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN E( M-1 ) = ZERO GO TO 60 END IF * IF( TOL.GE.ZERO ) THEN * * If relative accuracy desired, * apply convergence criterion forward * MU = ABS( D( LL ) ) SMINL = MU DO 100 LLL = LL, M - 1 IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN E( LLL ) = ZERO GO TO 60 END IF MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 100 CONTINUE END IF * ELSE * * Run convergence test in backward direction * First apply standard test to top of matrix * IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN E( LL ) = ZERO GO TO 60 END IF * IF( TOL.GE.ZERO ) THEN * * If relative accuracy desired, * apply convergence criterion backward * MU = ABS( D( M ) ) SMINL = MU DO 110 LLL = M - 1, LL, -1 IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN E( LLL ) = ZERO GO TO 60 END IF MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 110 CONTINUE END IF END IF OLDLL = LL OLDM = M * * Compute shift. First, test if shifting would ruin relative * accuracy, and if so set the shift to zero. * IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. $ MAX( EPS, HNDRTH*TOL ) ) THEN * * Use a zero shift to avoid loss of relative accuracy * SHIFT = ZERO ELSE * * Compute the shift from 2-by-2 block at end of matrix * IF( IDIR.EQ.1 ) THEN SLL = ABS( D( LL ) ) CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R ) ELSE SLL = ABS( D( M ) ) CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R ) END IF * * Test if shift negligible, and if so set to zero * IF( SLL.GT.ZERO ) THEN IF( ( SHIFT / SLL )**2.LT.EPS ) $ SHIFT = ZERO END IF END IF * * Increment iteration count * ITER = ITER + M - LL * * If SHIFT = 0, do simplified QR iteration * IF( SHIFT.EQ.ZERO ) THEN IF( IDIR.EQ.1 ) THEN * * Chase bulge from top to bottom * Save cosines and sines for later singular vector updates * CS = ONE OLDCS = ONE DO 120 I = LL, M - 1 CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) IF( I.GT.LL ) $ E( I-1 ) = OLDSN*R CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) RWORK( I-LL+1 ) = CS RWORK( I-LL+1+NM1 ) = SN RWORK( I-LL+1+NM12 ) = OLDCS RWORK( I-LL+1+NM13 ) = OLDSN 120 CONTINUE H = D( M )*CS D( M ) = H*OLDCS E( M-1 ) = H*OLDSN * * Update singular vectors * IF( NCVT.GT.0 ) $ CALL 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 ) * * Test convergence * IF( ABS( E( M-1 ) ).LE.THRESH ) $ E( M-1 ) = ZERO * ELSE * * Chase bulge from bottom to top * Save cosines and sines for later singular vector updates * CS = ONE OLDCS = ONE DO 130 I = M, LL + 1, -1 CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) IF( I.LT.M ) $ E( I ) = OLDSN*R CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) RWORK( I-LL ) = CS RWORK( I-LL+NM1 ) = -SN RWORK( I-LL+NM12 ) = OLDCS RWORK( I-LL+NM13 ) = -OLDSN 130 CONTINUE H = D( LL )*CS D( LL ) = H*OLDCS E( LL ) = H*OLDSN * * Update singular vectors * IF( NCVT.GT.0 ) $ CALL 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 ) * * Test convergence * IF( ABS( E( LL ) ).LE.THRESH ) $ E( LL ) = ZERO END IF ELSE * * Use nonzero shift * IF( IDIR.EQ.1 ) THEN * * Chase bulge from top to bottom * Save cosines and sines for later singular vector updates * F = ( ABS( D( LL ) )-SHIFT )* $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) G = E( LL ) DO 140 I = LL, M - 1 CALL DLARTG( F, G, COSR, SINR, R ) IF( I.GT.LL ) $ E( I-1 ) = R F = COSR*D( I ) + SINR*E( I ) E( I ) = COSR*E( I ) - SINR*D( I ) G = SINR*D( I+1 ) D( I+1 ) = COSR*D( I+1 ) CALL DLARTG( F, G, COSL, SINL, R ) D( I ) = R F = COSL*E( I ) + SINL*D( I+1 ) D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) IF( I.LT.M-1 ) THEN G = SINL*E( I+1 ) E( I+1 ) = COSL*E( I+1 ) END IF RWORK( I-LL+1 ) = COSR RWORK( I-LL+1+NM1 ) = SINR RWORK( I-LL+1+NM12 ) = COSL RWORK( I-LL+1+NM13 ) = SINL 140 CONTINUE E( M-1 ) = F * * Update singular vectors * 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 ) * * Test convergence * IF( ABS( E( M-1 ) ).LE.THRESH ) $ E( M-1 ) = ZERO * ELSE * * Chase bulge from bottom to top * Save cosines and sines for later singular vector updates * F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / $ D( M ) ) G = E( M-1 ) DO 150 I = M, LL + 1, -1 CALL DLARTG( F, G, COSR, SINR, R ) IF( I.LT.M ) $ E( I ) = R F = COSR*D( I ) + SINR*E( I-1 ) E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) G = SINR*D( I-1 ) D( I-1 ) = COSR*D( I-1 ) CALL DLARTG( F, G, COSL, SINL, R ) D( I ) = R F = COSL*E( I-1 ) + SINL*D( I-1 ) D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) IF( I.GT.LL+1 ) THEN G = SINL*E( I-2 ) E( I-2 ) = COSL*E( I-2 ) END IF RWORK( I-LL ) = COSR RWORK( I-LL+NM1 ) = -SINR RWORK( I-LL+NM12 ) = COSL RWORK( I-LL+NM13 ) = -SINL 150 CONTINUE E( LL ) = F * * Test convergence * IF( ABS( E( LL ) ).LE.THRESH ) $ E( LL ) = ZERO * * Update singular vectors if desired * IF( NCVT.GT.0 ) $ CALL 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 * * QR iteration finished, go back and check convergence * GO TO 60 * * All singular values converged, so make them positive * 160 CONTINUE DO 170 I = 1, N IF( D( I ).LT.ZERO ) THEN D( I ) = -D( I ) * * Change sign of singular vectors, if desired * IF( NCVT.GT.0 ) $ CALL ZDSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) END IF 170 CONTINUE * * Sort the singular values into decreasing order (insertion sort on * singular values, but only one transposition per singular vector) * DO 190 I = 1, N - 1 * * Scan for smallest D(I) * ISUB = 1 SMIN = D( 1 ) DO 180 J = 2, N + 1 - I IF( D( J ).LE.SMIN ) THEN ISUB = J SMIN = D( J ) END IF 180 CONTINUE IF( ISUB.NE.N+1-I ) THEN * * Swap singular values and vectors * D( ISUB ) = D( N+1-I ) D( N+1-I ) = SMIN IF( NCVT.GT.0 ) $ CALL ZSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), $ LDVT ) IF( NRU.GT.0 ) $ CALL ZSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 ) IF( NCC.GT.0 ) $ CALL ZSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) END IF 190 CONTINUE GO TO 220 * * Maximum number of iterations exceeded, failure to converge * 200 CONTINUE INFO = 0 DO 210 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 210 CONTINUE 220 CONTINUE RETURN * * End of ZBDSQR * END SUBROUTINE ZDRSCL( N, SA, SX, INCX ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION SA * .. * .. Array Arguments .. COMPLEX*16 SX( * ) * .. * * Purpose * ======= * * ZDRSCL multiplies an n-element complex vector x by the real scalar * 1/a. This is done without overflow or underflow as long as * the final result x/a does not overflow or underflow. * * Arguments * ========= * * N (input) INTEGER * The number of components of the vector x. * * SA (input) DOUBLE PRECISION * The scalar a which is used to divide each component of x. * SA must be >= 0, or the subroutine will divide by zero. * * SX (input/output) COMPLEX*16 array, dimension * (1+(N-1)*abs(INCX)) * The n-element vector x. * * INCX (input) INTEGER * The increment between successive values of the vector SX. * > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL DONE DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DLABAD, ZDSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Initialize the denominator to SA and the numerator to 1. * CDEN = SA CNUM = ONE * 10 CONTINUE CDEN1 = CDEN*SMLNUM CNUM1 = CNUM / BIGNUM IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN * * Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. * MUL = SMLNUM DONE = .FALSE. CDEN = CDEN1 ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN * * Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. * MUL = BIGNUM DONE = .FALSE. CNUM = CNUM1 ELSE * * Multiply X by CNUM / CDEN and return. * MUL = CNUM / CDEN DONE = .TRUE. END IF * * Scale the vector X by MUL * CALL ZDSCAL( N, MUL, SX, INCX ) * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of ZDRSCL * END SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. DOUBLE PRECISION SCALE( * ) COMPLEX*16 V( LDV, * ) * .. * * Purpose * ======= * * ZGEBAK forms the right or left eigenvectors of a complex general * matrix by backward transformation on the computed eigenvectors of the * balanced matrix output by ZGEBAL. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies the type of backward transformation required: * = 'N', do nothing, return immediately; * = 'P', do backward transformation for permutation only; * = 'S', do backward transformation for scaling only; * = 'B', do backward transformations for both permutation and * scaling. * JOB must be the same as the argument JOB supplied to ZGEBAL. * * SIDE (input) CHARACTER*1 * = 'R': V contains right eigenvectors; * = 'L': V contains left eigenvectors. * * N (input) INTEGER * The number of rows of the matrix V. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * The integers ILO and IHI determined by ZGEBAL. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * SCALE (input) DOUBLE PRECISION array, dimension (N) * Details of the permutation and scaling factors, as returned * by ZGEBAL. * * M (input) INTEGER * The number of columns of the matrix V. M >= 0. * * V (input/output) COMPLEX*16 array, dimension (LDV,M) * On entry, the matrix of right or left eigenvectors to be * transformed, as returned by ZHSEIN or ZTREVC. * On exit, V is overwritten by the transformed eigenvectors. * * LDV (input) INTEGER * The leading dimension of the array V. LDV >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, II, K DOUBLE PRECISION S * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Decode and Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -7 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * IF( RIGHTV ) THEN DO 10 I = ILO, IHI S = SCALE( I ) CALL ZDSCAL( M, S, V( I, 1 ), LDV ) 10 CONTINUE END IF * IF( LEFTV ) THEN DO 20 I = ILO, IHI S = ONE / SCALE( I ) CALL ZDSCAL( M, S, V( I, 1 ), LDV ) 20 CONTINUE END IF * END IF * * Backward permutation * * For I = ILO-1 step -1 until 1, * IHI+1 step 1 until N do -- * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN IF( RIGHTV ) THEN DO 40 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 40 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 40 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE END IF * IF( LEFTV ) THEN DO 50 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 50 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 50 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 50 CONTINUE END IF END IF * RETURN * * End of ZGEBAK * END SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER JOB INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION SCALE( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZGEBAL balances a general complex matrix A. This involves, first, * permuting A by a similarity transformation to isolate eigenvalues * in the first 1 to ILO-1 and last IHI+1 to N elements on the * diagonal; and second, applying a diagonal similarity transformation * to rows and columns ILO to IHI to make the rows and columns as * close in norm as possible. Both steps are optional. * * Balancing may reduce the 1-norm of the matrix, and improve the * accuracy of the computed eigenvalues and/or eigenvectors. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies the operations to be performed on A: * = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 * for i = 1,...,N; * = 'P': permute only; * = 'S': scale only; * = 'B': both permute and scale. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the input matrix A. * On exit, A is overwritten by the balanced matrix. * If JOB = 'N', A is not referenced. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * ILO (output) INTEGER * IHI (output) INTEGER * ILO and IHI are set to integers such that on exit * A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. * If JOB = 'N' or 'S', ILO = 1 and IHI = N. * * SCALE (output) DOUBLE PRECISION array, dimension (N) * Details of the permutations and scaling factors applied to * A. If P(j) is the index of the row and column interchanged * with row and column j and D(j) is the scaling factor * applied to row and column j, then * SCALE(j) = P(j) for j = 1,...,ILO-1 * = D(j) for j = ILO,...,IHI * = P(j) for j = IHI+1,...,N. * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The permutations consist of row and column interchanges which put * the matrix in the form * * ( T1 X Y ) * P A P = ( 0 B Z ) * ( 0 0 T2 ) * * where T1 and T2 are upper triangular matrices whose eigenvalues lie * along the diagonal. The column indices ILO and IHI mark the starting * and ending columns of the submatrix B. Balancing consists of applying * a diagonal similarity transformation inv(D) * B * D to make the * 1-norms of each row of B and its corresponding column nearly equal. * The output matrix is * * ( T1 X*D Y ) * ( 0 inv(D)*B*D inv(D)*Z ). * ( 0 0 T2 ) * * Information about the permutations P and the diagonal matrix D is * returned in the vector SCALE. * * This subroutine is based on the EISPACK routine CBAL. * * Modified by Tzu-Yi Chen, Computer Science Division, University of * California at Berkeley, USA * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC PARAMETER ( SCLFAC = 2.0D+0 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * .. * .. Local Scalars .. LOGICAL NOCONV INTEGER I, ICA, IEXC, IRA, J, K, L, M DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, $ SFMIN2 COMPLEX*16 CDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX, MIN * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEBAL', -INFO ) RETURN END IF * K = 1 L = N * IF( N.EQ.0 ) $ GO TO 210 * IF( LSAME( JOB, 'N' ) ) THEN DO 10 I = 1, N SCALE( I ) = ONE 10 CONTINUE GO TO 210 END IF * IF( LSAME( JOB, 'S' ) ) $ GO TO 120 * * Permutation to isolate eigenvalues if possible * GO TO 50 * * Row and column exchange. * 20 CONTINUE SCALE( M ) = J IF( J.EQ.M ) $ GO TO 30 * CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL ZSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) * 30 CONTINUE GO TO ( 40, 80 )IEXC * * Search for rows isolating an eigenvalue and push them down. * 40 CONTINUE IF( L.EQ.1 ) $ GO TO 210 L = L - 1 * 50 CONTINUE DO 70 J = L, 1, -1 * DO 60 I = 1, L IF( I.EQ.J ) $ GO TO 60 IF( DBLE( A( J, I ) ).NE.ZERO .OR. DIMAG( A( J, I ) ).NE. $ ZERO )GO TO 70 60 CONTINUE * M = L IEXC = 1 GO TO 20 70 CONTINUE * GO TO 90 * * Search for columns isolating an eigenvalue and push them left. * 80 CONTINUE K = K + 1 * 90 CONTINUE DO 110 J = K, L * DO 100 I = K, L IF( I.EQ.J ) $ GO TO 100 IF( DBLE( A( I, J ) ).NE.ZERO .OR. DIMAG( A( I, J ) ).NE. $ ZERO )GO TO 110 100 CONTINUE * M = K IEXC = 2 GO TO 20 110 CONTINUE * 120 CONTINUE DO 130 I = K, L SCALE( I ) = ONE 130 CONTINUE * IF( LSAME( JOB, 'P' ) ) $ GO TO 210 * * Balance the submatrix in rows K to L. * * Iterative loop for norm reduction * SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 140 CONTINUE NOCONV = .FALSE. * DO 200 I = K, L C = ZERO R = ZERO * DO 150 J = K, L IF( J.EQ.I ) $ GO TO 150 C = C + CABS1( A( J, I ) ) R = R + CABS1( A( I, J ) ) 150 CONTINUE ICA = IZAMAX( L, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = IZAMAX( N-K+1, A( I, K ), LDA ) RA = ABS( A( I, IRA+K-1 ) ) * * Guard against zero C or R due to underflow. * IF( C.EQ.ZERO .OR. R.EQ.ZERO ) $ GO TO 200 G = R / SCLFAC F = ONE S = C + R 160 CONTINUE IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 F = F*SCLFAC C = C*SCLFAC CA = CA*SCLFAC R = R / SCLFAC G = G / SCLFAC RA = RA / SCLFAC GO TO 160 * 170 CONTINUE G = C / SCLFAC 180 CONTINUE IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 F = F / SCLFAC C = C / SCLFAC G = G / SCLFAC CA = CA / SCLFAC R = R*SCLFAC RA = RA*SCLFAC GO TO 180 * * Now balance. * 190 CONTINUE IF( ( C+R ).GE.FACTOR*S ) $ GO TO 200 IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN IF( F*SCALE( I ).LE.SFMIN1 ) $ GO TO 200 END IF IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN IF( SCALE( I ).GE.SFMAX1 / F ) $ GO TO 200 END IF G = ONE / F SCALE( I ) = SCALE( I )*F NOCONV = .TRUE. * CALL ZDSCAL( N-K+1, G, A( I, K ), LDA ) CALL ZDSCAL( L, F, A( 1, I ), 1 ) * 200 CONTINUE * IF( NOCONV ) $ GO TO 140 * 210 CONTINUE ILO = K IHI = L * RETURN * * End of ZGEBAL * END SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEBD2 reduces a complex general m by n matrix A to upper or lower * real bidiagonal form B by a unitary transformation: Q' * A * P = B. * * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. * * Arguments * ========= * * M (input) INTEGER * The number of rows in the matrix A. M >= 0. * * N (input) INTEGER * The number of columns in the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n general matrix to be reduced. * On exit, * if m >= n, the diagonal and the first superdiagonal are * overwritten with the upper bidiagonal matrix B; the * elements below the diagonal, with the array TAUQ, represent * the unitary matrix Q as a product of elementary * reflectors, and the elements above the first superdiagonal, * with the array TAUP, represent the unitary matrix P as * a product of elementary reflectors; * if m < n, the diagonal and the first subdiagonal are * overwritten with the lower bidiagonal matrix B; the * elements below the first subdiagonal, with the array TAUQ, * represent the unitary matrix Q as a product of * elementary reflectors, and the elements above the diagonal, * with the array TAUP, represent the unitary matrix P as * a product of elementary reflectors. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * D (output) DOUBLE PRECISION array, dimension (min(M,N)) * The diagonal elements of the bidiagonal matrix B: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) * The off-diagonal elements of the bidiagonal matrix B: * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. * * TAUQ (output) COMPLEX*16 array dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the unitary matrix Q. See Further Details. * * TAUP (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the unitary matrix P. See Further Details. * * WORK (workspace) COMPLEX*16 array, dimension (max(M,N)) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The matrices Q and P are represented as products of elementary * reflectors: * * If m >= n, * * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are complex scalars, and v and u are complex * vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in * A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in * A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). * * If m < n, * * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are complex scalars, v and u are complex vectors; * v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); * u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); * tauq is stored in TAUQ(i) and taup in TAUP(i). * * The contents of A on exit are illustrated by the following examples: * * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): * * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) * ( v1 v2 v3 v4 v5 ) * * where d and e denote diagonal and off-diagonal elements of B, vi * denotes an element of the vector defining H(i), and ui an element of * the vector defining G(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'ZGEBD2', -INFO ) RETURN END IF * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, N * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * 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 * * Apply H(i)' to A(i:m,i+1:n) from the left * IF( I.LT.N ) $ CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN * * Generate elementary reflector G(i) to annihilate * A(i,i+2:n) * CALL 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 * * Apply G(i) to A(i+1:m,i+1:n) from the right * 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 * * Reduce to lower bidiagonal form * DO 20 I = 1, M * * Generate elementary reflector G(i) to annihilate A(i,i+1:n) * 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 * * Apply G(i) to A(i+1:m,i:n) from the right * IF( I.LT.M ) $ CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, $ TAUP( I ), A( I+1, I ), LDA, WORK ) CALL ZLACGV( N-I+1, A( I, I ), LDA ) A( I, I ) = D( I ) * IF( I.LT.M ) THEN * * Generate elementary reflector H(i) to annihilate * A(i+2:m,i) * 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 * * Apply H(i)' to A(i+1:m,i+1:n) from the left * CALL ZLARF( 'Left', M-I, N-I, A( I+1, I ), 1, $ DCONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA, $ WORK ) A( I+1, I ) = E( I ) ELSE TAUQ( I ) = ZERO END IF 20 CONTINUE END IF RETURN * * End of ZGEBD2 * END SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEBRD reduces a general complex M-by-N matrix A to upper or lower * bidiagonal form B by a unitary transformation: Q**H * A * P = B. * * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. * * Arguments * ========= * * M (input) INTEGER * The number of rows in the matrix A. M >= 0. * * N (input) INTEGER * The number of columns in the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N general matrix to be reduced. * On exit, * if m >= n, the diagonal and the first superdiagonal are * overwritten with the upper bidiagonal matrix B; the * elements below the diagonal, with the array TAUQ, represent * the unitary matrix Q as a product of elementary * reflectors, and the elements above the first superdiagonal, * with the array TAUP, represent the unitary matrix P as * a product of elementary reflectors; * if m < n, the diagonal and the first subdiagonal are * overwritten with the lower bidiagonal matrix B; the * elements below the first subdiagonal, with the array TAUQ, * represent the unitary matrix Q as a product of * elementary reflectors, and the elements above the diagonal, * with the array TAUP, represent the unitary matrix P as * a product of elementary reflectors. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * D (output) DOUBLE PRECISION array, dimension (min(M,N)) * The diagonal elements of the bidiagonal matrix B: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) * The off-diagonal elements of the bidiagonal matrix B: * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. * * TAUQ (output) COMPLEX*16 array dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the unitary matrix Q. See Further Details. * * TAUP (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the unitary matrix P. See Further Details. * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,M,N). * For optimum performance LWORK >= (M+N)*NB, where NB * is the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The matrices Q and P are represented as products of elementary * reflectors: * * If m >= n, * * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are complex scalars, and v and u are complex * vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in * A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in * A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). * * If m < n, * * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are complex scalars, and v and u are complex * vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in * A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). * * The contents of A on exit are illustrated by the following examples: * * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): * * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) * ( v1 v2 v3 v4 v5 ) * * where d and e denote diagonal and off-diagonal elements of B, vi * denotes an element of the vector defining H(i), and ui an element of * the vector defining G(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, $ NBMIN, NX DOUBLE PRECISION WS * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEBD2, ZGEMM, ZLABRD * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) ) LWKOPT = ( M+N )*NB WORK( 1 ) = DBLE( LWKOPT ) LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN INFO = -10 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'ZGEBRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * WS = MAX( M, N ) LDWRKX = M LDWRKY = N * IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN * * Set the crossover point NX. * NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) ) * * Determine when to switch from blocked to unblocked code. * IF( NX.LT.MINMN ) THEN WS = ( M+N )*NB IF( LWORK.LT.WS ) THEN * * Not enough work space for the optimal NB, consider using * a smaller block size. * NBMIN = ILAENV( 2, '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 * DO 30 I = 1, MINMN - NX, NB * * Reduce rows and columns i:i+ib-1 to bidiagonal form and return * the matrices X and Y which are needed to update the unreduced * part of the matrix * 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 ) * * Update the trailing submatrix A(i+ib:m,i+ib:n), using * an update of the form A := A - V*Y' - X*U' * CALL ZGEMM( '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 ZGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, $ ONE, A( I+NB, I+NB ), LDA ) * * Copy diagonal and off-diagonal elements of B back into A * IF( M.GE.N ) THEN DO 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 * * Use unblocked code to reduce the remainder of the matrix * 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 of ZGEBRD * END SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER NORM INTEGER INFO, LDA, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ) COMPLEX*16 A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * ZGECON estimates the reciprocal of the condition number of a general * complex matrix A, in either the 1-norm or the infinity-norm, using * the LU factorization computed by ZGETRF. * * An estimate is obtained for norm(inv(A)), and the reciprocal of the * condition number is computed as * RCOND = 1 / ( norm(A) * norm(inv(A)) ). * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies whether the 1-norm condition number or the * infinity-norm condition number is required: * = '1' or 'O': 1-norm; * = 'I': Infinity-norm. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The factors L and U from the factorization A = P*L*U * as computed by ZGETRF. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * ANORM (input) DOUBLE PRECISION * If NORM = '1' or 'O', the 1-norm of the original matrix A. * If NORM = 'I', the infinity-norm of the original matrix A. * * RCOND (output) DOUBLE PRECISION * The reciprocal of the condition number of the matrix A, * computed as RCOND = 1/(norm(A) * norm(inv(A))). * * WORK (workspace) COMPLEX*16 array, dimension (2*N) * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL ONENRM CHARACTER NORMIN INTEGER IX, KASE, KASE1 DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU COMPLEX*16 ZDUM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( ANORM.LT.ZERO ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGECON', -INFO ) RETURN END IF * * Quick return if possible * RCOND = ZERO IF( N.EQ.0 ) THEN RCOND = ONE RETURN ELSE IF( ANORM.EQ.ZERO ) THEN RETURN END IF * SMLNUM = DLAMCH( 'Safe minimum' ) * * Estimate the norm of inv(A). * AINVNM = ZERO NORMIN = 'N' IF( ONENRM ) THEN KASE1 = 1 ELSE KASE1 = 2 END IF KASE = 0 10 CONTINUE CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * * Multiply by inv(L). * CALL ZLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A, $ LDA, WORK, SL, RWORK, INFO ) * * Multiply by inv(U). * CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, $ A, LDA, WORK, SU, RWORK( N+1 ), INFO ) ELSE * * Multiply by inv(U'). * CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', $ NORMIN, N, A, LDA, WORK, SU, RWORK( N+1 ), $ INFO ) * * Multiply by inv(L'). * CALL ZLATRS( 'Lower', 'Conjugate transpose', 'Unit', NORMIN, $ N, A, LDA, WORK, SL, RWORK, INFO ) END IF * * Divide X by 1/(SL*SU) if doing so will not cause overflow. * SCALE = SL*SU NORMIN = 'Y' IF( SCALE.NE.ONE ) THEN IX = IZAMAX( N, WORK, 1 ) IF( SCALE.LT.CABS1( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) $ GO TO 20 CALL ZDRSCL( N, SCALE, WORK, 1 ) END IF GO TO 10 END IF * * Compute the estimate of the reciprocal condition number. * IF( AINVNM.NE.ZERO ) $ RCOND = ( ONE / AINVNM ) / ANORM * 20 CONTINUE RETURN * * End of ZGECON * END SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, $ WORK, LWORK, RWORK, INFO ) * * -- LAPACK driver routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR INTEGER INFO, LDA, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ) COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), $ W( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the * eigenvalues and, optionally, the left and/or right eigenvectors. * * The right eigenvector v(j) of A satisfies * A * v(j) = lambda(j) * v(j) * where lambda(j) is its eigenvalue. * The left eigenvector u(j) of A satisfies * u(j)**H * A = lambda(j) * u(j)**H * where u(j)**H denotes the conjugate transpose of u(j). * * The computed eigenvectors are normalized to have Euclidean norm * equal to 1 and largest component real. * * Arguments * ========= * * JOBVL (input) CHARACTER*1 * = 'N': left eigenvectors of A are not computed; * = 'V': left eigenvectors of are computed. * * JOBVR (input) CHARACTER*1 * = 'N': right eigenvectors of A are not computed; * = 'V': right eigenvectors of A are computed. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the N-by-N matrix A. * On exit, A has been overwritten. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * W (output) COMPLEX*16 array, dimension (N) * W contains the computed eigenvalues. * * VL (output) COMPLEX*16 array, dimension (LDVL,N) * If JOBVL = 'V', the left eigenvectors u(j) are stored one * after another in the columns of VL, in the same order * as their eigenvalues. * If JOBVL = 'N', VL is not referenced. * u(j) = VL(:,j), the j-th column of VL. * * LDVL (input) INTEGER * The leading dimension of the array VL. LDVL >= 1; if * JOBVL = 'V', LDVL >= N. * * VR (output) COMPLEX*16 array, dimension (LDVR,N) * If JOBVR = 'V', the right eigenvectors v(j) are stored one * after another in the columns of VR, in the same order * as their eigenvalues. * If JOBVR = 'N', VR is not referenced. * v(j) = VR(:,j), the j-th column of VR. * * LDVR (input) INTEGER * The leading dimension of the array VR. LDVR >= 1; if * JOBVR = 'V', LDVR >= N. * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,2*N). * For good performance, LWORK must generally be larger. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * > 0: if INFO = i, the QR algorithm failed to compute all the * eigenvalues, and no eigenvectors have been computed; * elements and i+1:N of W contain eigenvalues which have * converged. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, $ IWRK, K, MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM COMPLEX*16 TMP * .. * .. Local Arrays .. LOGICAL SELECT( 1 ) DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, $ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, ILAENV DOUBLE PRECISION DLAMCH, DZNRM2, ZLANGE EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) WANTVL = LSAME( JOBVL, 'V' ) WANTVR = LSAME( JOBVR, 'V' ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN INFO = -1 ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN INFO = -8 ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN INFO = -10 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * CWorkspace refers to complex workspace, and RWorkspace to real * workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV. * HSWORK refers to the workspace preferred by ZHSEQR, as * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * IF( INFO.EQ.0 ) THEN IF( N.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 ELSE MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) MINWRK = 2*N IF( WANTVL ) THEN MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', $ ' ', N, 1, N, -1 ) ) CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL, $ WORK, -1, INFO ) ELSE IF( WANTVR ) THEN MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', $ ' ', N, 1, N, -1 ) ) CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR, $ WORK, -1, INFO ) ELSE CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR, $ WORK, -1, INFO ) END IF HSWORK = WORK( 1 ) MAXWRK = MAX( MAXWRK, HSWORK, MINWRK ) END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -12 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEEV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = ZLANGE( 'M', N, N, A, LDA, DUM ) SCALEA = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN SCALEA = .TRUE. CSCALE = SMLNUM ELSE IF( ANRM.GT.BIGNUM ) THEN SCALEA = .TRUE. CSCALE = BIGNUM END IF IF( SCALEA ) $ CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) * * Balance the matrix * (CWorkspace: none) * (RWorkspace: need N) * IBAL = 1 CALL ZGEBAL( 'B', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR ) * * Reduce to upper Hessenberg form * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: none) * ITAU = 1 IWRK = ITAU + N CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * IF( WANTVL ) THEN * * Want left eigenvectors * Copy Householder vectors to VL * SIDE = 'L' CALL ZLACPY( 'L', N, N, A, LDA, VL, LDVL ) * * Generate unitary matrix in VL * (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) * (RWorkspace: none) * CALL ZUNGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * * Perform QR iteration, accumulating Schur vectors in VL * (CWorkspace: need 1, prefer HSWORK (see comments) ) * (RWorkspace: none) * IWRK = ITAU CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VL, LDVL, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) * IF( WANTVR ) THEN * * Want left and right eigenvectors * Copy Schur vectors to VR * SIDE = 'B' CALL ZLACPY( 'F', N, N, VL, LDVL, VR, LDVR ) END IF * ELSE IF( WANTVR ) THEN * * Want right eigenvectors * Copy Householder vectors to VR * SIDE = 'R' CALL ZLACPY( 'L', N, N, A, LDA, VR, LDVR ) * * Generate unitary matrix in VR * (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) * (RWorkspace: none) * CALL ZUNGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * * Perform QR iteration, accumulating Schur vectors in VR * (CWorkspace: need 1, prefer HSWORK (see comments) ) * (RWorkspace: none) * IWRK = ITAU CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VR, LDVR, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) * ELSE * * Compute eigenvalues only * (CWorkspace: need 1, prefer HSWORK (see comments) ) * (RWorkspace: none) * IWRK = ITAU CALL ZHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, W, VR, LDVR, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) END IF * * If INFO > 0 from ZHSEQR, then quit * IF( INFO.GT.0 ) $ GO TO 50 * IF( WANTVL .OR. WANTVR ) THEN * * Compute left and/or right eigenvectors * (CWorkspace: need 2*N) * (RWorkspace: need 2*N) * IRWORK = IBAL + N CALL ZTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, $ N, NOUT, WORK( IWRK ), RWORK( IRWORK ), IERR ) END IF * IF( WANTVL ) THEN * * Undo balancing of left eigenvectors * (CWorkspace: none) * (RWorkspace: need N) * CALL ZGEBAK( 'B', 'L', N, ILO, IHI, RWORK( IBAL ), N, VL, LDVL, $ IERR ) * * Normalize left eigenvectors and make largest component real * DO 20 I = 1, N SCL = ONE / DZNRM2( N, VL( 1, I ), 1 ) CALL ZDSCAL( N, SCL, VL( 1, I ), 1 ) DO 10 K = 1, N RWORK( IRWORK+K-1 ) = DBLE( VL( K, I ) )**2 + $ DIMAG( VL( K, I ) )**2 10 CONTINUE K = IDAMAX( N, RWORK( IRWORK ), 1 ) TMP = DCONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) CALL ZSCAL( N, TMP, VL( 1, I ), 1 ) VL( K, I ) = DCMPLX( DBLE( VL( K, I ) ), ZERO ) 20 CONTINUE END IF * IF( WANTVR ) THEN * * Undo balancing of right eigenvectors * (CWorkspace: none) * (RWorkspace: need N) * CALL ZGEBAK( 'B', 'R', N, ILO, IHI, RWORK( IBAL ), N, VR, LDVR, $ IERR ) * * Normalize right eigenvectors and make largest component real * DO 40 I = 1, N SCL = ONE / DZNRM2( N, VR( 1, I ), 1 ) CALL ZDSCAL( N, SCL, VR( 1, I ), 1 ) DO 30 K = 1, N RWORK( IRWORK+K-1 ) = DBLE( VR( K, I ) )**2 + $ DIMAG( VR( K, I ) )**2 30 CONTINUE K = IDAMAX( N, RWORK( IRWORK ), 1 ) TMP = DCONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) CALL ZSCAL( N, TMP, VR( 1, I ), 1 ) VR( K, I ) = DCMPLX( DBLE( VR( K, I ) ), ZERO ) 40 CONTINUE END IF * * Undo scaling if necessary * 50 CONTINUE IF( SCALEA ) THEN CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, W( INFO+1 ), $ MAX( N-INFO, 1 ), IERR ) IF( INFO.GT.0 ) THEN CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR ) END IF END IF * WORK( 1 ) = MAXWRK RETURN * * End of ZGEEV * END SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H * by a unitary similarity transformation: Q' * A * Q = H . * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that A is already upper triangular in rows * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally * set by a previous call to ZGEBAL; otherwise they should be * set to 1 and N respectively. See Further Details. * 1 <= ILO <= IHI <= max(1,N). * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the n by n general matrix to be reduced. * On exit, the upper triangle and the first subdiagonal of A * are overwritten with the upper Hessenberg matrix H, and the * elements below the first subdiagonal, with the array TAU, * represent the unitary matrix Q as a product of elementary * reflectors. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * TAU (output) COMPLEX*16 array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) COMPLEX*16 array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The matrix Q is represented as a product of (ihi-ilo) elementary * reflectors * * Q = H(ilo) H(ilo+1) . . . H(ihi-1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on * exit in A(i+2:ihi,i), and tau in TAU(i). * * The contents of A are illustrated by the following example, with * n = 7, ilo = 2 and ihi = 6: * * on entry, on exit, * * ( a a a a a a a ) ( a a h h h h a ) * ( a a a a a a ) ( a h h h h a ) * ( a a a a a a ) ( h h h h h h ) * ( a a a a a a ) ( v2 h h h h h ) * ( a a a a a a ) ( v2 v3 h h h h ) * ( a a a a a a ) ( v2 v3 v4 h h h ) * ( a ) ( a ) * * where a denotes an element of the original matrix A, h denotes a * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF, ZLARFG * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEHD2', -INFO ) RETURN END IF * DO 10 I = ILO, IHI - 1 * * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) * ALPHA = A( I+1, I ) CALL ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) ) A( I+1, I ) = ONE * * Apply H(i) to A(1:ihi,i+1:ihi) from the right * CALL ZLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), $ A( 1, I+1 ), LDA, WORK ) * * Apply H(i)' to A(i+1:ihi,i+1:n) from the left * CALL ZLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, $ DCONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) * A( I+1, I ) = ALPHA 10 CONTINUE * RETURN * * End of ZGEHD2 * END SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by * an unitary similarity transformation: Q' * A * Q = H . * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that A is already upper triangular in rows * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally * set by a previous call to ZGEBAL; otherwise they should be * set to 1 and N respectively. See Further Details. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the N-by-N general matrix to be reduced. * On exit, the upper triangle and the first subdiagonal of A * are overwritten with the upper Hessenberg matrix H, and the * elements below the first subdiagonal, with the array TAU, * represent the unitary matrix Q as a product of elementary * reflectors. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * TAU (output) COMPLEX*16 array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to * zero. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK >= N*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The matrix Q is represented as a product of (ihi-ilo) elementary * reflectors * * Q = H(ilo) H(ilo+1) . . . H(ihi-1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on * exit in A(i+2:ihi,i), and tau in TAU(i). * * The contents of A are illustrated by the following example, with * n = 7, ilo = 2 and ihi = 6: * * on entry, on exit, * * ( a a a a a a a ) ( a a h h h h a ) * ( a a a a a a ) ( a h h h h a ) * ( a a a a a a ) ( h h h h h h ) * ( a a a a a a ) ( v2 h h h h h ) * ( a a a a a a ) ( v2 v3 h h h h ) * ( a a a a a a ) ( v2 v3 v4 h h h ) * ( a ) ( a ) * * where a denotes an element of the original matrix A, h denotes a * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * * This file is a slight modification of LAPACK-3.0's ZGEHRD * subroutine incorporating improvements proposed by Quintana-Orti and * Van de Geijn (2005). * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB, $ NBMIN, NH, NX COMPLEX*16 EI * .. * .. Local Arrays .. COMPLEX*16 T( LDT, NBMAX ) * .. * .. External Subroutines .. EXTERNAL ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) LWKOPT = N*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEHRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Set elements 1:ILO-1 and IHI:N-1 of TAU to zero * DO 10 I = 1, ILO - 1 TAU( I ) = ZERO 10 CONTINUE DO 20 I = MAX( 1, IHI ), N - 1 TAU( I ) = ZERO 20 CONTINUE * * Quick return if possible * NH = IHI - ILO + 1 IF( NH.LE.1 ) THEN WORK( 1 ) = 1 RETURN END IF * * Determine the block size * NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) NBMIN = 2 IWS = 1 IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code * (last block is always handled by unblocked code) * NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * * Determine if workspace is large enough for blocked code * IWS = N*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of * unblocked code * NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI, $ -1 ) ) IF( LWORK.GE.N*NBMIN ) THEN NB = LWORK / N ELSE NB = 1 END IF END IF END IF END IF LDWORK = N * IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN * * Use unblocked code below * I = ILO * ELSE * * Use blocked code * DO 40 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V' * which performs the reduction, and also the matrix Y = A*V*T * CALL ZLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, $ WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V'. V(i+ib,ib-1) must be set * to 1 * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ IHI, IHI-I-IB+1, $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, $ A( 1, I+IB ), LDA ) A( I+IB, I+IB-1 ) = EI * * Apply the block reflector H to A(1:i,i+1:i+ib-1) from the * right * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', I, IB-1, $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) DO 30 J = 0, IB-2 CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, $ A( 1, I+J+1 ), 1 ) 30 CONTINUE * * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', $ 'Columnwise', $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, $ A( I+1, I+IB ), LDA, WORK, LDWORK ) 40 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix * CALL ZGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) WORK( 1 ) = IWS * RETURN * * End of ZGEHRD * END SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGELQ2 computes an LQ factorization of a complex m by n matrix A: * A = L * Q. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the elements on and below the diagonal of the array * contain the m by min(m,n) lower trapezoidal matrix L (L is * lower triangular if m <= n); the elements above the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) COMPLEX*16 array, dimension (M) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in * A(i,i+1:n), and tau in TAU(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELQ2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i,i+1:n) * CALL 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 * * Apply H(i) to A(i+1:m,i:n) from the right * 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 of ZGELQ2 * END SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGELQF computes an LQ factorization of a complex M-by-N matrix A: * A = L * Q. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, the elements on and below the diagonal of the array * contain the m-by-min(m,n) lower trapezoidal matrix L (L is * lower triangular if m <= n); the elements above the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,M). * For optimum performance LWORK >= M*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in * A(i,i+1:n), and tau in TAU(i). * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGELQ2, ZLARFB, ZLARFT * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) LWKOPT = M*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELQF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZGELQF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZGELQF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the LQ factorization of the current block * A(i:i+ib-1,i:n) * CALL ZGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.M ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i+ib:m,i:n) from the right * CALL 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 * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL ZGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of ZGELQF * END SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION RWORK( * ) COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEQP3 computes a QR factorization with column pivoting of a * matrix A: A*P = Q*R using Level 3 BLAS. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, the upper triangle of the array contains the * min(M,N)-by-N upper trapezoidal matrix R; the elements below * the diagonal, together with the array TAU, represent the * unitary matrix Q as a product of min(M,N) elementary * reflectors. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * JPVT (input/output) INTEGER array, dimension (N) * On entry, if JPVT(J).ne.0, the J-th column of A is permuted * to the front of A*P (a leading column); if JPVT(J)=0, * the J-th column of A is a free column. * On exit, if JPVT(J)=K, then the J-th column of A*P was the * the K-th column of A. * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors. * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO=0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= N+1. * For optimal performance LWORK >= ( N+1 )*NB, where NB * is the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real/complex scalar, and v is a real/complex vector * with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in * A(i+1:m,i), and tau in TAU(i). * * Based on contributions by * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain * X. Sun, Computer Science Dept., Duke University, USA * * ===================================================================== * * .. Parameters .. INTEGER INB, INBMIN, IXOVER PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQRF, ZLAQP2, ZLAQPS, ZSWAP, ZUNMQR * .. * .. External Functions .. INTEGER ILAENV DOUBLE PRECISION DZNRM2 EXTERNAL ILAENV, DZNRM2 * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * * Test input arguments * ==================== * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF * IF( INFO.EQ.0 ) THEN MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN IWS = 1 LWKOPT = 1 ELSE IWS = N + 1 NB = ILAENV( INB, 'ZGEQRF', ' ', M, N, -1, -1 ) LWKOPT = ( N + 1 )*NB END IF WORK( 1 ) = LWKOPT * IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQP3', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible. * IF( MINMN.EQ.0 ) THEN RETURN END IF * * Move initial columns up front. * NFXD = 1 DO 10 J = 1, N IF( JPVT( J ).NE.0 ) THEN IF( J.NE.NFXD ) THEN CALL ZSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) JPVT( J ) = JPVT( NFXD ) JPVT( NFXD ) = J ELSE JPVT( J ) = J END IF NFXD = NFXD + 1 ELSE JPVT( J ) = J END IF 10 CONTINUE NFXD = NFXD - 1 * * Factorize fixed columns * ======================= * * Compute the QR factorization of fixed columns and update * remaining columns. * IF( NFXD.GT.0 ) THEN NA = MIN( M, NFXD ) *CC CALL ZGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) CALL ZGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) IWS = MAX( IWS, INT( WORK( 1 ) ) ) IF( NA.LT.N ) THEN *CC CALL ZUNM2R( 'Left', 'Conjugate Transpose', M, N-NA, *CC $ NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK, *CC $ INFO ) CALL ZUNMQR( 'Left', 'Conjugate Transpose', M, N-NA, NA, A, $ LDA, TAU, A( 1, NA+1 ), LDA, WORK, LWORK, $ INFO ) IWS = MAX( IWS, INT( WORK( 1 ) ) ) END IF END IF * * Factorize free columns * ====================== * IF( NFXD.LT.MINMN ) THEN * SM = M - NFXD SN = N - NFXD SMINMN = MINMN - NFXD * * Determine the block size. * NB = ILAENV( INB, 'ZGEQRF', ' ', SM, SN, -1, -1 ) NBMIN = 2 NX = 0 * IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( IXOVER, 'ZGEQRF', ' ', SM, SN, -1, $ -1 ) ) * * IF( NX.LT.SMINMN ) THEN * * Determine if workspace is large enough for blocked code. * MINWS = ( SN+1 )*NB IWS = MAX( IWS, MINWS ) IF( LWORK.LT.MINWS ) THEN * * Not enough workspace to use optimal NB: Reduce NB and * determine the minimum value of NB. * NB = LWORK / ( SN+1 ) NBMIN = MAX( 2, ILAENV( INBMIN, 'ZGEQRF', ' ', SM, SN, $ -1, -1 ) ) * * END IF END IF END IF * * Initialize partial column norms. The first N elements of work * store the exact column norms. * DO 20 J = NFXD + 1, N RWORK( J ) = DZNRM2( SM, A( NFXD+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) 20 CONTINUE * IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. $ ( NX.LT.SMINMN ) ) THEN * * Use blocked code initially. * J = NFXD + 1 * * Compute factorization: while loop. * * TOPBMN = MINMN - NX 30 CONTINUE IF( J.LE.TOPBMN ) THEN JB = MIN( NB, TOPBMN-J+1 ) * * Factorize JB columns among columns J:N. * CALL ZLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, $ JPVT( J ), TAU( J ), RWORK( J ), $ RWORK( N+J ), WORK( 1 ), WORK( JB+1 ), $ N-J+1 ) * J = J + FJB GO TO 30 END IF ELSE J = NFXD + 1 END IF * * Use unblocked code to factor the last or only block. * * IF( J.LE.MINMN ) $ CALL ZLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), $ TAU( J ), RWORK( J ), RWORK( N+J ), WORK( 1 ) ) * END IF * WORK( 1 ) = IWS RETURN * * End of ZGEQP3 * END SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEQR2 computes a QR factorization of a complex m by n matrix A: * A = Q * R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(m,n) by n upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) COMPLEX*16 array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF, ZLARFG * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i)' to A(i:m,i+1:n) from the left * ALPHA = A( I, I ) A( I, I ) = ONE CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = ALPHA END IF 10 CONTINUE RETURN * * End of ZGEQR2 * END SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEQRF computes a QR factorization of a complex M-by-N matrix A: * A = Q * R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(M,N)-by-N upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of min(m,n) elementary reflectors (see Further * Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK >= N*NB, where NB is * the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQR2, ZLARFB, ZLARFT * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQRF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZGEQRF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the QR factorization of the current block * A(i:m,i:i+ib-1) * CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H' to A(i:m,i+ib:n) from the left * CALL 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 * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of ZGEQRF * END SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * -- LAPACK driver routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZGESV computes the solution to a complex system of linear equations * A * X = B, * where A is an N-by-N matrix and X and B are N-by-NRHS matrices. * * The LU decomposition with partial pivoting and row interchanges is * used to factor A as * A = P * L * U, * where P is a permutation matrix, L is unit lower triangular, and U is * upper triangular. The factored form of A is then used to solve the * system of equations A * X = B. * * Arguments * ========= * * N (input) INTEGER * The number of linear equations, i.e., the order of the * matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the N-by-N coefficient matrix A. * On exit, the factors L and U from the factorization * A = P*L*U; the unit diagonal elements of L are not stored. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (output) INTEGER array, dimension (N) * The pivot indices that define the permutation matrix P; * row i of the matrix was interchanged with row IPIV(i). * * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) * On entry, the N-by-NRHS matrix of right hand side matrix B. * On exit, if INFO = 0, the N-by-NRHS solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, U(i,i) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, so the solution could not be computed. * * ===================================================================== * * .. External Subroutines .. EXTERNAL XERBLA, ZGETRF, ZGETRS * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NRHS.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGESV ', -INFO ) RETURN END IF * * Compute the LU factorization of A. * CALL ZGETRF( N, N, A, LDA, IPIV, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * CALL ZGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, $ INFO ) END IF RETURN * * End of ZGESV * END SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, RWORK, INFO ) * * -- LAPACK driver routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ), S( * ) COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ), $ WORK( * ) * .. * * Purpose * ======= * * ZGESVD computes the singular value decomposition (SVD) of a complex * M-by-N matrix A, optionally computing the left and/or right singular * vectors. The SVD is written * * A = U * SIGMA * conjugate-transpose(V) * * where SIGMA is an M-by-N matrix which is zero except for its * min(m,n) diagonal elements, U is an M-by-M unitary matrix, and * V is an N-by-N unitary matrix. The diagonal elements of SIGMA * are the singular values of A; they are real and non-negative, and * are returned in descending order. The first min(m,n) columns of * U and V are the left and right singular vectors of A. * * Note that the routine returns V**H, not V. * * Arguments * ========= * * JOBU (input) CHARACTER*1 * Specifies options for computing all or part of the matrix U: * = 'A': all M columns of U are returned in array U: * = 'S': the first min(m,n) columns of U (the left singular * vectors) are returned in the array U; * = 'O': the first min(m,n) columns of U (the left singular * vectors) are overwritten on the array A; * = 'N': no columns of U (no left singular vectors) are * computed. * * JOBVT (input) CHARACTER*1 * Specifies options for computing all or part of the matrix * V**H: * = 'A': all N rows of V**H are returned in the array VT; * = 'S': the first min(m,n) rows of V**H (the right singular * vectors) are returned in the array VT; * = 'O': the first min(m,n) rows of V**H (the right singular * vectors) are overwritten on the array A; * = 'N': no rows of V**H (no right singular vectors) are * computed. * * JOBVT and JOBU cannot both be 'O'. * * M (input) INTEGER * The number of rows of the input matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the input matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, * if JOBU = 'O', A is overwritten with the first min(m,n) * columns of U (the left singular vectors, * stored columnwise); * if JOBVT = 'O', A is overwritten with the first min(m,n) * rows of V**H (the right singular vectors, * stored rowwise); * if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A * are destroyed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * S (output) DOUBLE PRECISION array, dimension (min(M,N)) * The singular values of A, sorted so that S(i) >= S(i+1). * * U (output) COMPLEX*16 array, dimension (LDU,UCOL) * (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. * If JOBU = 'A', U contains the M-by-M unitary matrix U; * if JOBU = 'S', U contains the first min(m,n) columns of U * (the left singular vectors, stored columnwise); * if JOBU = 'N' or 'O', U is not referenced. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= 1; if * JOBU = 'S' or 'A', LDU >= M. * * VT (output) COMPLEX*16 array, dimension (LDVT,N) * If JOBVT = 'A', VT contains the N-by-N unitary matrix * V**H; * if JOBVT = 'S', VT contains the first min(m,n) rows of * V**H (the right singular vectors, stored rowwise); * if JOBVT = 'N' or 'O', VT is not referenced. * * LDVT (input) INTEGER * The leading dimension of the array VT. LDVT >= 1; if * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)). * For good performance, LWORK should generally be larger. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)) * On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the * unconverged superdiagonal elements of an upper bidiagonal * matrix B whose diagonal is in S (not necessarily sorted). * B satisfies A = U * B * VT, so it has the same singular * values as A, and singular vectors related by U and VT. * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * > 0: if ZBDSQR did not converge, INFO specifies how many * superdiagonals of an intermediate bidiagonal form B * did not converge to zero. See the description of RWORK * above for details. * * ===================================================================== * * .. Parameters .. COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS INTEGER BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL, $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, $ NRVT, WRKBL DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) COMPLEX*16 CDUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DLASCL, XERBLA, ZBDSQR, ZGEBRD, ZGELQF, ZGEMM, $ ZGEQRF, ZLACPY, ZLASCL, ZLASET, ZUNGBR, ZUNGLQ, $ ZUNGQR, ZUNMBR * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 MINMN = MIN( M, N ) WNTUA = LSAME( JOBU, 'A' ) WNTUS = LSAME( JOBU, 'S' ) WNTUAS = WNTUA .OR. WNTUS WNTUO = LSAME( JOBU, 'O' ) WNTUN = LSAME( JOBU, 'N' ) WNTVA = LSAME( JOBVT, 'A' ) WNTVS = LSAME( JOBVT, 'S' ) WNTVAS = WNTVA .OR. WNTVS WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN INFO = -1 ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR. $ ( WNTVO .AND. WNTUO ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN INFO = -9 ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR. $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN INFO = -11 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * CWorkspace refers to complex workspace, and RWorkspace to * real workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV.) * IF( INFO.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 IF( M.GE.N .AND. MINMN.GT.0 ) THEN * * Space needed for ZBDSQR is BDSPAC = 5*N * MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN * * Path 1 (M much larger than N, JOBU='N') * 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 ELSE IF( WNTUO .AND. WNTVN ) THEN * * Path 2 (M much larger than N, JOBU='O', JOBVT='N') * 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 ELSE IF( WNTUO .AND. WNTVAS ) THEN * * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or * 'A') * 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 ELSE IF( WNTUS .AND. WNTVN ) THEN * * Path 4 (M much larger than N, JOBU='S', JOBVT='N') * 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 ELSE IF( WNTUS .AND. WNTVO ) THEN * * Path 5 (M much larger than N, JOBU='S', JOBVT='O') * 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 ELSE IF( WNTUS .AND. WNTVAS ) THEN * * Path 6 (M much larger than N, JOBU='S', JOBVT='S' or * 'A') * 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 ELSE IF( WNTUA .AND. WNTVN ) THEN * * Path 7 (M much larger than N, JOBU='A', JOBVT='N') * 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 ELSE IF( WNTUA .AND. WNTVO ) THEN * * Path 8 (M much larger than N, JOBU='A', JOBVT='O') * 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 ELSE IF( WNTUA .AND. WNTVAS ) THEN * * Path 9 (M much larger than N, JOBU='A', JOBVT='S' or * 'A') * 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 END IF ELSE * * Path 10 (M at least N, but not much larger) * 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 END IF ELSE IF( MINMN.GT.0 ) THEN * * Space needed for ZBDSQR is BDSPAC = 5*M * MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN * * Path 1t(N much larger than M, JOBVT='N') * 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 ELSE IF( WNTVO .AND. WNTUN ) THEN * * Path 2t(N much larger than M, JOBU='N', JOBVT='O') * 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 ELSE IF( WNTVO .AND. WNTUAS ) THEN * * Path 3t(N much larger than M, JOBU='S' or 'A', * JOBVT='O') * 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 ELSE IF( WNTVS .AND. WNTUN ) THEN * * Path 4t(N much larger than M, JOBU='N', JOBVT='S') * 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 ELSE IF( WNTVS .AND. WNTUO ) THEN * * Path 5t(N much larger than M, JOBU='O', JOBVT='S') * 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 ELSE IF( WNTVS .AND. WNTUAS ) THEN * * Path 6t(N much larger than M, JOBU='S' or 'A', * JOBVT='S') * 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 ELSE IF( WNTVA .AND. WNTUN ) THEN * * Path 7t(N much larger than M, JOBU='N', JOBVT='A') * 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 ELSE IF( WNTVA .AND. WNTUO ) THEN * * Path 8t(N much larger than M, JOBU='O', JOBVT='A') * 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 ELSE IF( WNTVA .AND. WNTUAS ) THEN * * Path 9t(N much larger than M, JOBU='S' or 'A', * JOBVT='A') * 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 END IF ELSE * * Path 10t(N greater than M, but not much larger) * 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 END IF END IF MAXWRK = MAX( MAXWRK, MINWRK ) WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -13 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGESVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = 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 * IF( M.GE.N ) THEN * * A has at least as many rows as columns. If A has sufficiently * more rows than columns, first reduce using the QR * decomposition (if sufficient workspace available) * IF( M.GE.MNTHR ) THEN * IF( WNTUN ) THEN * * Path 1 (M much larger than N, JOBU='N') * No left singular vectors to be computed * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: need 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Zero out below R * CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ), $ LDA ) IE = 1 ITAUQ = 1 ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * 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 * * If right singular vectors desired, generate P'. * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) NCVT = N END IF IRWORK = IE + N * * Perform bidiagonal QR iteration, computing right * singular vectors of A in A if desired * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, NCVT, 0, 0, S, RWORK( IE ), A, LDA, $ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO ) * * If right singular vectors desired in VT, copy them there * IF( WNTVAS ) $ CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT ) * ELSE IF( WNTUO .AND. WNTVN ) THEN * * Path 2 (M much larger than N, JOBU='O', JOBVT='N') * N left singular vectors to be overwritten on A and * no right singular vectors to be computed * IF( LWORK.GE.N*N+3*N ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN * * WORK(IU) is LDA by N, WORK(IR) is LDA by N * LDWRKU = LDA LDWRKR = LDA ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN * * WORK(IU) is LDA by N, WORK(IR) is N by N * LDWRKU = LDA LDWRKR = N ELSE * * WORK(IU) is LDWRKU by N, WORK(IR) is N by N * LDWRKU = ( LWORK-N*N ) / N LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IR) and zero out below it * CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IR+1 ), LDWRKR ) * * Generate Q in A * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize R in WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing R * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) * (RWorkspace: need 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) * (CWorkspace: need N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, 1, $ WORK( IR ), LDWRKR, CDUM, 1, $ RWORK( IRWORK ), INFO ) IU = ITAUQ * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in WORK(IU) and copying to A * (CWorkspace: need N*N+N, prefer N*N+M*N) * (RWorkspace: 0) * DO 10 I = 1, M, LDWRKU CHUNK = MIN( M-I+1, LDWRKU ) CALL ZGEMM( '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 * ELSE * * Insufficient workspace for a fast algorithm * IE = 1 ITAUQ = 1 ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize A * (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) * (RWorkspace: N) * CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing A * (CWorkspace: need 3*N, prefer 2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in A * (CWorkspace: need 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, 1, $ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTUO .AND. WNTVAS ) THEN * * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') * N left singular vectors to be overwritten on A and * N right singular vectors to be computed in VT * IF( LWORK.GE.N*N+3*N ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by N * LDWRKU = LDA LDWRKR = LDA ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * LDWRKU = LDA LDWRKR = N ELSE * * WORK(IU) is LDWRKU by N and WORK(IR) is N by N * LDWRKU = ( LWORK-N*N ) / N LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) IF( N.GT.1 ) $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ VT( 2, 1 ), LDVT ) * * Generate Q in A * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize R in VT, copying result to WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) * (RWorkspace: need N) * 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 ) * * Generate left vectors bidiagonalizing R in WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in VT * (CWorkspace: need N*N+3*N-1, prefer N*N+2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) and computing right * singular vectors of R in VT * (CWorkspace: need N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT, $ LDVT, WORK( IR ), LDWRKR, CDUM, 1, $ RWORK( IRWORK ), INFO ) IU = ITAUQ * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in WORK(IU) and copying to A * (CWorkspace: need N*N+N, prefer N*N+M*N) * (RWorkspace: 0) * DO 20 I = 1, M, LDWRKU CHUNK = MIN( M-I+1, LDWRKU ) CALL ZGEMM( '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 * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) IF( N.GT.1 ) $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ VT( 2, 1 ), LDVT ) * * Generate Q in A * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize R in VT * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: N) * CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in A by left vectors bidiagonalizing R * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), A, LDA, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in VT * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in A and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT, $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ), $ INFO ) * END IF * ELSE IF( WNTUS ) THEN * IF( WNTVN ) THEN * * Path 4 (M much larger than N, JOBU='S', JOBVT='N') * N left singular vectors to be computed in U and * no right singular vectors to be computed * IF( LWORK.GE.N*N+3*N ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.WRKBL+LDA*N ) THEN * * WORK(IR) is LDA by N * LDWRKR = LDA ELSE * * WORK(IR) is N by N * LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IR), zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), $ LDWRKR ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IR+1 ), LDWRKR ) * * Generate Q in A * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize R in WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing R in WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) * (CWorkspace: need N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, $ 1, WORK( IR ), LDWRKR, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in U * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, $ WORK( IR ), LDWRKR, CZERO, U, LDU ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * 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 * * Zero out below R in A * CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ A( 2, 1 ), LDA ) * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left vectors bidiagonalizing R * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, $ 1, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) * END IF * ELSE IF( WNTVO ) THEN * * Path 5 (M much larger than N, JOBU='S', JOBVT='O') * N left singular vectors to be computed in U and * N right singular vectors to be overwritten on A * IF( LWORK.GE.2*N*N+3*N ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+2*LDA*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by N * LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = LDA ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = N ELSE * * WORK(IU) is N by N and WORK(IR) is N by N * LDWRKU = N IR = IU + LDWRKU*N LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IU), zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), $ LDWRKU ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IU+1 ), LDWRKU ) * * Generate Q in A * (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize R in WORK(IU), copying result to * WORK(IR) * (CWorkspace: need 2*N*N+3*N, * prefer 2*N*N+2*N+2*N*NB) * (RWorkspace: need N) * 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 ) * * Generate left bidiagonalizing vectors in WORK(IU) * (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) * (CWorkspace: need 2*N*N+3*N-1, * prefer 2*N*N+2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in WORK(IR) * (CWorkspace: need 2*N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), $ WORK( IR ), LDWRKR, WORK( IU ), $ LDWRKU, CDUM, 1, RWORK( IRWORK ), $ INFO ) * * Multiply Q in A by left singular vectors of R in * WORK(IU), storing result in U * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, $ WORK( IU ), LDWRKU, CZERO, U, LDU ) * * Copy right singular vectors of R to A * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, $ LDA ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * 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 * * Zero out below R in A * CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ A( 2, 1 ), LDA ) * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left vectors bidiagonalizing R * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in A * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in A * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A, $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) * END IF * ELSE IF( WNTVAS ) THEN * * Path 6 (M much larger than N, JOBU='S', JOBVT='S' * or 'A') * N left singular vectors to be computed in U and * N right singular vectors to be computed in VT * IF( LWORK.GE.N*N+3*N ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+LDA*N ) THEN * * WORK(IU) is LDA by N * LDWRKU = LDA ELSE * * WORK(IU) is N by N * LDWRKU = N END IF ITAU = IU + LDWRKU*N IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IU), zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), $ LDWRKU ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IU+1 ), LDWRKU ) * * Generate Q in A * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize R in WORK(IU), copying result to VT * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) * (RWorkspace: need N) * 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 ) * * Generate left bidiagonalizing vectors in WORK(IU) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT * (CWorkspace: need N*N+3*N-1, * prefer N*N+2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in VT * (CWorkspace: need N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT, $ LDVT, WORK( IU ), LDWRKU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply Q in A by left singular vectors of R in * WORK(IU), storing result in U * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, $ WORK( IU ), LDWRKU, CZERO, U, LDU ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) IF( N.GT.1 ) $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ VT( 2, 1 ), LDVT ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in VT * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left bidiagonalizing vectors * in VT * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT, $ LDVT, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * END IF * ELSE IF( WNTUA ) THEN * IF( WNTVN ) THEN * * Path 7 (M much larger than N, JOBU='A', JOBVT='N') * M left singular vectors to be computed in U and * no right singular vectors to be computed * IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.WRKBL+LDA*N ) THEN * * WORK(IR) is LDA by N * LDWRKR = LDA ELSE * * WORK(IR) is N by N * LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Copy R to WORK(IR), zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), $ LDWRKR ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IR+1 ), LDWRKR ) * * Generate Q in U * (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize R in WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) * (CWorkspace: need N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, $ 1, WORK( IR ), LDWRKR, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply Q in U by left singular vectors of R in * WORK(IR), storing result in A * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, $ WORK( IR ), LDWRKR, CZERO, A, LDA ) * * Copy left singular vectors of A from A to U * CALL ZLACPY( 'F', M, N, A, LDA, U, LDU ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need N+M, prefer N+M*NB) * (RWorkspace: 0) * 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 * * Zero out below R in A * CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ A( 2, 1 ), LDA ) * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left bidiagonalizing vectors * in A * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, $ 1, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) * END IF * ELSE IF( WNTVO ) THEN * * Path 8 (M much larger than N, JOBU='A', JOBVT='O') * M left singular vectors to be computed in U and * N right singular vectors to be overwritten on A * IF( LWORK.GE.2*N*N+MAX( N+M, 3*N ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+2*LDA*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by N * LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = LDA ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = N ELSE * * WORK(IU) is N by N and WORK(IR) is N by N * LDWRKU = N IR = IU + LDWRKU*N LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IU), zeroing out below it * 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 * * Bidiagonalize R in WORK(IU), copying result to * WORK(IR) * (CWorkspace: need 2*N*N+3*N, * prefer 2*N*N+2*N+2*N*NB) * (RWorkspace: need N) * 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 ) * * Generate left bidiagonalizing vectors in WORK(IU) * (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) * (CWorkspace: need 2*N*N+3*N-1, * prefer 2*N*N+2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in WORK(IR) * (CWorkspace: need 2*N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), $ WORK( IR ), LDWRKR, WORK( IU ), $ LDWRKU, CDUM, 1, RWORK( IRWORK ), $ INFO ) * * Multiply Q in U by left singular vectors of R in * WORK(IU), storing result in A * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, $ WORK( IU ), LDWRKU, CZERO, A, LDA ) * * Copy left singular vectors of A from A to U * CALL ZLACPY( 'F', M, N, A, LDA, U, LDU ) * * Copy right singular vectors of R from WORK(IR) to A * CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, $ LDA ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need N+M, prefer N+M*NB) * (RWorkspace: 0) * 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 * * Zero out below R in A * CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ A( 2, 1 ), LDA ) * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left bidiagonalizing vectors * in A * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in A * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in A * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A, $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) * END IF * ELSE IF( WNTVAS ) THEN * * Path 9 (M much larger than N, JOBU='A', JOBVT='S' * or 'A') * M left singular vectors to be computed in U and * N right singular vectors to be computed in VT * IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+LDA*N ) THEN * * WORK(IU) is LDA by N * LDWRKU = LDA ELSE * * WORK(IU) is N by N * LDWRKU = N END IF ITAU = IU + LDWRKU*N IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IU), zeroing out below it * 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 * * Bidiagonalize R in WORK(IU), copying result to VT * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) * (RWorkspace: need N) * 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 ) * * Generate left bidiagonalizing vectors in WORK(IU) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT * (CWorkspace: need N*N+3*N-1, * prefer N*N+2*N+(N-1)*NB) * (RWorkspace: need 0) * CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in VT * (CWorkspace: need N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT, $ LDVT, WORK( IU ), LDWRKU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply Q in U by left singular vectors of R in * WORK(IU), storing result in A * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, $ WORK( IU ), LDWRKU, CZERO, A, LDA ) * * Copy left singular vectors of A from A to U * CALL ZLACPY( 'F', M, N, A, LDA, U, LDU ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need N+M, prefer N+M*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R from A to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) IF( N.GT.1 ) $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ VT( 2, 1 ), LDVT ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in VT * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left bidiagonalizing vectors * in VT * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT, $ LDVT, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * END IF * END IF * ELSE * * M .LT. MNTHR * * Path 10 (M at least N, but not much larger) * Reduce to bidiagonal form without QR decomposition * IE = 1 ITAUQ = 1 ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize A * (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) * (RWorkspace: need N) * CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ IERR ) IF( WNTUAS ) THEN * * If left singular vectors desired in U, copy result to U * and generate left bidiagonalizing vectors in U * (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB) * (RWorkspace: 0) * 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 * * If right singular vectors desired in VT, copy result to * VT and generate right bidiagonalizing vectors in VT * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * 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 * * If left singular vectors desired in A, generate left * bidiagonalizing vectors in A * (CWorkspace: need 3*N, prefer 2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTVO ) THEN * * If right singular vectors desired in A, generate right * bidiagonalizing vectors in A * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * 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 * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in U and computing right singular * vectors in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * 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 * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in U and computing right singular * vectors in A * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), A, $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) ELSE * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in A and computing right singular * vectors in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT, $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ), $ INFO ) END IF * END IF * ELSE * * A has more columns than rows. If A has sufficiently more * columns than rows, first reduce using the LQ decomposition (if * sufficient workspace available) * IF( N.GE.MNTHR ) THEN * IF( WNTVN ) THEN * * Path 1t(N much larger than M, JOBVT='N') * No right singular vectors to be computed * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Zero out above L * CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ), $ LDA ) IE = 1 ITAUQ = 1 ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in A * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ IERR ) IF( WNTUO .OR. WNTUAS ) THEN * * If left singular vectors desired, generate Q * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * 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 * * Perform bidiagonal QR iteration, computing left singular * vectors of A in A if desired * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, 0, NRU, 0, S, RWORK( IE ), CDUM, 1, $ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO ) * * If left singular vectors desired in U, copy them there * IF( WNTUAS ) $ CALL ZLACPY( 'F', M, M, A, LDA, U, LDU ) * ELSE IF( WNTVO .AND. WNTUN ) THEN * * Path 2t(N much larger than M, JOBU='N', JOBVT='O') * M right singular vectors to be overwritten on A and * no left singular vectors to be computed * IF( LWORK.GE.M*M+3*M ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by M * LDWRKU = LDA CHUNK = N LDWRKR = LDA ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is M by M * LDWRKU = LDA CHUNK = N LDWRKR = M ELSE * * WORK(IU) is M by CHUNK and WORK(IR) is M by M * LDWRKU = M CHUNK = ( LWORK-M*M ) / M LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IR) and zero out above it * CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in A * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize L in WORK(IR) * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing L * (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) * (CWorkspace: need M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ), $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1, $ RWORK( IRWORK ), INFO ) IU = ITAUQ * * Multiply right singular vectors of L in WORK(IR) by Q * in A, storing result in WORK(IU) and copying to A * (CWorkspace: need M*M+M, prefer M*M+M*N) * (RWorkspace: 0) * DO 30 I = 1, N, CHUNK BLK = MIN( N-I+1, CHUNK ) CALL ZGEMM( '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 * ELSE * * Insufficient workspace for a fast algorithm * IE = 1 ITAUQ = 1 ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize A * (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing A * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of A in A * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'L', M, N, 0, 0, S, RWORK( IE ), A, LDA, $ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTVO .AND. WNTUAS ) THEN * * Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') * M right singular vectors to be overwritten on A and * M left singular vectors to be computed in U * IF( LWORK.GE.M*M+3*M ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by M * LDWRKU = LDA CHUNK = N LDWRKR = LDA ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is M by M * LDWRKU = LDA CHUNK = N LDWRKR = M ELSE * * WORK(IU) is M by CHUNK and WORK(IR) is M by M * LDWRKU = M CHUNK = ( LWORK-M*M ) / M LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to U, zeroing about above it * CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ), $ LDU ) * * Generate Q in A * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize L in U, copying result to WORK(IR) * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) * (RWorkspace: need M) * 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 ) * * Generate right vectors bidiagonalizing L in WORK(IR) * (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing L in U * (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in U, and computing right * singular vectors of L in WORK(IR) * (CWorkspace: need M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), $ WORK( IR ), LDWRKR, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) IU = ITAUQ * * Multiply right singular vectors of L in WORK(IR) by Q * in A, storing result in WORK(IU) and copying to A * (CWorkspace: need M*M+M, prefer M*M+M*N)) * (RWorkspace: 0) * DO 40 I = 1, N, CHUNK BLK = MIN( N-I+1, CHUNK ) CALL ZGEMM( '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 * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to U, zeroing out above it * CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ), $ LDU ) * * Generate Q in A * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize L in U * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in A * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU, $ WORK( ITAUP ), A, LDA, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing L in U * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in A * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), A, LDA, $ U, LDU, CDUM, 1, RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTVS ) THEN * IF( WNTUN ) THEN * * Path 4t(N much larger than M, JOBU='N', JOBVT='S') * M right singular vectors to be computed in VT and * no left singular vectors to be computed * IF( LWORK.GE.M*M+3*M ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.WRKBL+LDA*M ) THEN * * WORK(IR) is LDA by M * LDWRKR = LDA ELSE * * WORK(IR) is M by M * LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IR), zeroing out above it * CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), $ LDWRKR ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in A * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize L in WORK(IR) * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing L in * WORK(IR) * (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) * (CWorkspace: need M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ), $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IR) by * Q in A, storing result in VT * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ), $ LDWRKR, A, LDA, CZERO, VT, LDVT ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy result to VT * CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * 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 * * Zero out above L in A * CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ A( 1, 2 ), LDA ) * * Bidiagonalize L in A * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in VT * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT, $ LDVT, CDUM, 1, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTUO ) THEN * * Path 5t(N much larger than M, JOBU='O', JOBVT='S') * M right singular vectors to be computed in VT and * M left singular vectors to be overwritten on A * IF( LWORK.GE.2*M*M+3*M ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+2*LDA*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is LDA by M * LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = LDA ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is M by M * LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = M ELSE * * WORK(IU) is M by M and WORK(IR) is M by M * LDWRKU = M IR = IU + LDWRKU*M LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IU), zeroing out below it * CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), $ LDWRKU ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( IU+LDWRKU ), LDWRKU ) * * Generate Q in A * (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize L in WORK(IU), copying result to * WORK(IR) * (CWorkspace: need 2*M*M+3*M, * prefer 2*M*M+2*M+2*M*NB) * (RWorkspace: need M) * 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 ) * * Generate right bidiagonalizing vectors in WORK(IU) * (CWorkspace: need 2*M*M+3*M-1, * prefer 2*M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) * (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in WORK(IR) and computing * right singular vectors of L in WORK(IU) * (CWorkspace: need 2*M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), $ WORK( IU ), LDWRKU, WORK( IR ), $ LDWRKR, CDUM, 1, RWORK( IRWORK ), $ INFO ) * * Multiply right singular vectors of L in WORK(IU) by * Q in A, storing result in VT * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), $ LDWRKU, A, LDA, CZERO, VT, LDVT ) * * Copy left singular vectors of L to A * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, $ LDA ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * 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 * * Zero out above L in A * CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ A( 1, 2 ), LDA ) * * Bidiagonalize L in A * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in VT * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors of L in A * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in A and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, $ LDVT, A, LDA, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTUAS ) THEN * * Path 6t(N much larger than M, JOBU='S' or 'A', * JOBVT='S') * M right singular vectors to be computed in VT and * M left singular vectors to be computed in U * IF( LWORK.GE.M*M+3*M ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+LDA*M ) THEN * * WORK(IU) is LDA by N * LDWRKU = LDA ELSE * * WORK(IU) is LDA by M * LDWRKU = M END IF ITAU = IU + LDWRKU*M IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IU), zeroing out above it * CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), $ LDWRKU ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( IU+LDWRKU ), LDWRKU ) * * Generate Q in A * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize L in WORK(IU), copying result to U * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) * (RWorkspace: need M) * 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 ) * * Generate right bidiagonalizing vectors in WORK(IU) * (CWorkspace: need M*M+3*M-1, * prefer M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U * (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in U and computing right * singular vectors of L in WORK(IU) * (CWorkspace: need M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), $ WORK( IU ), LDWRKU, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IU) by * Q in A, storing result in VT * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), $ LDWRKU, A, LDA, CZERO, VT, LDVT ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to U, zeroing out above it * 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 * * Bidiagonalize L in U * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right bidiagonalizing vectors in U by Q * in VT * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, $ LDVT, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * END IF * ELSE IF( WNTVA ) THEN * IF( WNTUN ) THEN * * Path 7t(N much larger than M, JOBU='N', JOBVT='A') * N right singular vectors to be computed in VT and * no left singular vectors to be computed * IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.WRKBL+LDA*M ) THEN * * WORK(IR) is LDA by M * LDWRKR = LDA ELSE * * WORK(IR) is M by M * LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Copy L to WORK(IR), zeroing out above it * CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), $ LDWRKR ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in VT * (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB) * (RWorkspace: 0) * 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 * * Bidiagonalize L in WORK(IR) * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) * (CWorkspace: need M*M+3*M-1, * prefer M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) * (CWorkspace: need M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ), $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IR) by * Q in VT, storing result in A * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ), $ LDWRKR, VT, LDVT, CZERO, A, LDA ) * * Copy right singular vectors of A from A to VT * CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need M+N, prefer M+N*NB) * (RWorkspace: 0) * 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 * * Zero out above L in A * CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ A( 1, 2 ), LDA ) * * Bidiagonalize L in A * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right bidiagonalizing vectors in A by Q * in VT * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT, $ LDVT, CDUM, 1, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTUO ) THEN * * Path 8t(N much larger than M, JOBU='O', JOBVT='A') * N right singular vectors to be computed in VT and * M left singular vectors to be overwritten on A * IF( LWORK.GE.2*M*M+MAX( N+M, 3*M ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+2*LDA*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is LDA by M * LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = LDA ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is M by M * LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = M ELSE * * WORK(IU) is M by M and WORK(IR) is M by M * LDWRKU = M IR = IU + LDWRKU*M LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) * (RWorkspace: 0) * CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IU), zeroing out above it * 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 * * Bidiagonalize L in WORK(IU), copying result to * WORK(IR) * (CWorkspace: need 2*M*M+3*M, * prefer 2*M*M+2*M+2*M*NB) * (RWorkspace: need M) * 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 ) * * Generate right bidiagonalizing vectors in WORK(IU) * (CWorkspace: need 2*M*M+3*M-1, * prefer 2*M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) * (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in WORK(IR) and computing * right singular vectors of L in WORK(IU) * (CWorkspace: need 2*M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), $ WORK( IU ), LDWRKU, WORK( IR ), $ LDWRKR, CDUM, 1, RWORK( IRWORK ), $ INFO ) * * Multiply right singular vectors of L in WORK(IU) by * Q in VT, storing result in A * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), $ LDWRKU, VT, LDVT, CZERO, A, LDA ) * * Copy right singular vectors of A from A to VT * CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT ) * * Copy left singular vectors of A from WORK(IR) to A * CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, $ LDA ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need M+N, prefer M+N*NB) * (RWorkspace: 0) * 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 * * Zero out above L in A * CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ A( 1, 2 ), LDA ) * * Bidiagonalize L in A * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right bidiagonalizing vectors in A by Q * in VT * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in A * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in A and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, $ LDVT, A, LDA, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTUAS ) THEN * * Path 9t(N much larger than M, JOBU='S' or 'A', * JOBVT='A') * N right singular vectors to be computed in VT and * M left singular vectors to be computed in U * IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+LDA*M ) THEN * * WORK(IU) is LDA by M * LDWRKU = LDA ELSE * * WORK(IU) is M by M * LDWRKU = M END IF ITAU = IU + LDWRKU*M IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB) * (RWorkspace: 0) * CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IU), zeroing out above it * 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 * * Bidiagonalize L in WORK(IU), copying result to U * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) * (RWorkspace: need M) * 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 ) * * Generate right bidiagonalizing vectors in WORK(IU) * (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U * (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in U and computing right * singular vectors of L in WORK(IU) * (CWorkspace: need M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), $ WORK( IU ), LDWRKU, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IU) by * Q in VT, storing result in A * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), $ LDWRKU, VT, LDVT, CZERO, A, LDA ) * * Copy right singular vectors of A from A to VT * CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need M+N, prefer M+N*NB) * (RWorkspace: 0) * CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to U, zeroing out above it * 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 * * Bidiagonalize L in U * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right bidiagonalizing vectors in U by Q * in VT * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, $ LDVT, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * END IF * END IF * ELSE * * N .LT. MNTHR * * Path 10t(N greater than M, but not much larger) * Reduce to bidiagonal form without LQ decomposition * IE = 1 ITAUQ = 1 ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize A * (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) * (RWorkspace: M) * CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ IERR ) IF( WNTUAS ) THEN * * If left singular vectors desired in U, copy result to U * and generate left bidiagonalizing vectors in U * (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB) * (RWorkspace: 0) * 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 * * If right singular vectors desired in VT, copy result to * VT and generate right bidiagonalizing vectors in VT * (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB) * (RWorkspace: 0) * 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 * * If left singular vectors desired in A, generate left * bidiagonalizing vectors in A * (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTVO ) THEN * * If right singular vectors desired in A, generate right * bidiagonalizing vectors in A * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * 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 * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in U and computing right singular * vectors in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * 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 * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in U and computing right singular * vectors in A * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), A, $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) ELSE * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in A and computing right singular * vectors in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT, $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ), $ INFO ) END IF * END IF * END IF * * Undo scaling if necessary * IF( ISCL.EQ.1 ) THEN IF( ANRM.GT.BIGNUM ) $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) IF( 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 * * Return optimal workspace in WORK(1) * WORK( 1 ) = MAXWRK * RETURN * * End of ZGESVD * END SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZGETF2 computes an LU factorization of a general m-by-n matrix A * using partial pivoting with row interchanges. * * The factorization has the form * A = P * L * U * where P is a permutation matrix, L is lower triangular with unit * diagonal elements (lower trapezoidal if m > n), and U is upper * triangular (upper trapezoidal if m < n). * * This is the right-looking Level 2 BLAS version of the algorithm. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix to be factored. * On exit, the factors L and U from the factorization * A = P*L*U; the unit diagonal elements of L are not stored. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * IPIV (output) INTEGER array, dimension (min(M,N)) * The pivot indices; for 1 <= i <= min(M,N), row i of the * matrix was interchanged with row IPIV(i). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * > 0: if INFO = k, U(k,k) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. DOUBLE PRECISION SFMIN INTEGER I, J, JP * .. * .. External Functions .. DOUBLE PRECISION DLAMCH INTEGER IZAMAX EXTERNAL DLAMCH, IZAMAX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGETF2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Compute machine safe minimum * SFMIN = DLAMCH('S') * DO 10 J = 1, MIN( M, N ) * * Find pivot and test for singularity. * JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 ) IPIV( J ) = JP IF( A( JP, J ).NE.ZERO ) THEN * * Apply the interchange to columns 1:N. * IF( JP.NE.J ) $ CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) * * Compute elements J+1:M of J-th column. * IF( J.LT.M ) THEN IF( ABS(A( J, J )) .GE. SFMIN ) THEN CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) ELSE DO 20 I = 1, M-J A( J+I, J ) = A( J+I, J ) / A( J, J ) 20 CONTINUE END IF END IF * ELSE IF( INFO.EQ.0 ) THEN * INFO = J END IF * IF( J.LT.MIN( M, N ) ) THEN * * Update trailing submatrix. * CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), $ LDA, A( J+1, J+1 ), LDA ) END IF 10 CONTINUE RETURN * * End of ZGETF2 * END SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZGETRF computes an LU factorization of a general M-by-N matrix A * using partial pivoting with row interchanges. * * The factorization has the form * A = P * L * U * where P is a permutation matrix, L is lower triangular with unit * diagonal elements (lower trapezoidal if m > n), and U is upper * triangular (upper trapezoidal if m < n). * * This is the right-looking Level 3 BLAS version of the algorithm. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N matrix to be factored. * On exit, the factors L and U from the factorization * A = P*L*U; the unit diagonal elements of L are not stored. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * IPIV (output) INTEGER array, dimension (min(M,N)) * The pivot indices; for 1 <= i <= min(M,N), row i of the * matrix was interchanged with row IPIV(i). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, U(i,i) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, IINFO, J, JB, NB * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEMM, ZGETF2, ZLASWP, ZTRSM * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGETRF', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Determine the block size for this environment. * NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN * * Use unblocked code. * CALL ZGETF2( M, N, A, LDA, IPIV, INFO ) ELSE * * Use blocked code. * DO 20 J = 1, MIN( M, N ), NB JB = MIN( MIN( M, N )-J+1, NB ) * * Factor diagonal and subdiagonal blocks and test for exact * singularity. * CALL ZGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) * * Adjust INFO and the pivot indices. * IF( INFO.EQ.0 .AND. IINFO.GT.0 ) $ INFO = IINFO + J - 1 DO 10 I = J, MIN( M, J+JB-1 ) IPIV( I ) = J - 1 + IPIV( I ) 10 CONTINUE * * Apply interchanges to columns 1:J-1. * CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) * IF( J+JB.LE.N ) THEN * * Apply interchanges to columns J+JB:N. * CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, $ IPIV, 1 ) * * Compute block row of U. * CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), $ LDA ) IF( J+JB.LE.M ) THEN * * Update trailing submatrix. * CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1, $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), $ LDA ) END IF END IF 20 CONTINUE END IF RETURN * * End of ZGETRF * END SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZGETRS solves a system of linear equations * A * X = B, A**T * X = B, or A**H * X = B * with a general N-by-N matrix A using the LU factorization computed * by ZGETRF. * * Arguments * ========= * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations: * = 'N': A * X = B (No transpose) * = 'T': A**T * X = B (Transpose) * = 'C': A**H * X = B (Conjugate transpose) * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The factors L and U from the factorization A = P*L*U * as computed by ZGETRF. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (input) INTEGER array, dimension (N) * The pivot indices from ZGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL NOTRAN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLASWP, ZTRSM * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGETRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( NOTRAN ) THEN * * Solve A * X = B. * * Apply row interchanges to the right hand sides. * CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) * * Solve L*X = B, overwriting B with X. * CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, $ ONE, A, LDA, B, LDB ) * * Solve U*X = B, overwriting B with X. * CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, $ NRHS, ONE, A, LDA, B, LDB ) ELSE * * Solve A**T * X = B or A**H * X = B. * * Solve U'*X = B, overwriting B with X. * CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, $ A, LDA, B, LDB ) * * Solve L'*X = B, overwriting B with X. * CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A, $ LDA, B, LDB ) * * Apply row interchanges to the solution vectors. * CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) END IF * RETURN * * End of ZGETRS * END SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ INFO ) * * -- LAPACK driver routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ), W( * ) COMPLEX*16 A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * ZHEEV computes all eigenvalues and, optionally, eigenvectors of a * complex Hermitian matrix A. * * Arguments * ========= * * JOBZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only; * = 'V': Compute eigenvalues and eigenvectors. * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA, N) * On entry, the Hermitian matrix A. If UPLO = 'U', the * leading N-by-N upper triangular part of A contains the * upper triangular part of the matrix A. If UPLO = 'L', * the leading N-by-N lower triangular part of A contains * the lower triangular part of the matrix A. * On exit, if JOBZ = 'V', then if INFO = 0, A contains the * orthonormal eigenvectors of the matrix A. * If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') * or the upper triangle (if UPLO='U') of A, including the * diagonal, is destroyed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * W (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, the eigenvalues in ascending order. * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,2*N-1). * For optimal efficiency, LWORK >= (NB+1)*N, * where NB is the blocksize for ZHETRD returned by ILAENV. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, the algorithm failed to converge; i * off-diagonal elements of an intermediate tridiagonal * form did not converge to zero. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) * .. * .. Local Scalars .. LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, $ LLWORK, LWKOPT, NB DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, ZLANHE EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE * .. * .. External Subroutines .. EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR, $ ZUNGTR * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) LOWER = LSAME( UPLO, 'L' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( 1, ( NB+1 )*N ) WORK( 1 ) = LWKOPT * IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) $ INFO = -8 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHEEV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN RETURN END IF * IF( N.EQ.1 ) THEN W( 1 ) = A( 1, 1 ) WORK( 1 ) = 1 IF( WANTZ ) $ A( 1, 1 ) = CONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * Scale matrix to allowable range, if necessary. * ANRM = ZLANHE( 'M', UPLO, N, A, LDA, 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 ) $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) * * Call ZHETRD to reduce Hermitian matrix to tridiagonal form. * INDE = 1 INDTAU = 1 INDWRK = INDTAU + N LLWORK = LWORK - INDWRK + 1 CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ), $ WORK( INDWRK ), LLWORK, IINFO ) * * For eigenvalues only, call DSTERF. For eigenvectors, first call * ZUNGTR to generate the unitary matrix, then call ZSTEQR. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, RWORK( INDE ), INFO ) ELSE CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), $ LLWORK, IINFO ) INDWRK = INDE + N CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA, $ RWORK( INDWRK ), INFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = N ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * * Set WORK(1) to optimal complex workspace size. * WORK( 1 ) = LWKOPT * RETURN * * End of ZHEEV * END SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAU( * ) * .. * * Purpose * ======= * * ZHETD2 reduces a complex Hermitian matrix A to real symmetric * tridiagonal form T by a unitary similarity transformation: * Q' * A * Q = T. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * Hermitian matrix A is stored: * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the Hermitian matrix A. If UPLO = 'U', the leading * n-by-n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n-by-n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * On exit, if UPLO = 'U', the diagonal and first superdiagonal * of A are overwritten by the corresponding elements of the * tridiagonal matrix T, and the elements above the first * superdiagonal, with the array TAU, represent the unitary * matrix Q as a product of elementary reflectors; if UPLO * = 'L', the diagonal and first subdiagonal of A are over- * written by the corresponding elements of the tridiagonal * matrix T, and the elements below the first subdiagonal, with * the array TAU, represent the unitary matrix Q as a product * of elementary reflectors. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * D (output) DOUBLE PRECISION array, dimension (N) * The diagonal elements of the tridiagonal matrix T: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (N-1) * The off-diagonal elements of the tridiagonal matrix T: * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. * * TAU (output) COMPLEX*16 array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * If UPLO = 'U', the matrix Q is represented as a product of elementary * reflectors * * Q = H(n-1) . . . H(2) H(1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in * A(1:i-1,i+1), and tau in TAU(i). * * If UPLO = 'L', the matrix Q is represented as a product of elementary * reflectors * * Q = H(1) H(2) . . . H(n-1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), * and tau in TAU(i). * * The contents of A on exit are illustrated by the following examples * with n = 5: * * if UPLO = 'U': if UPLO = 'L': * * ( d e v2 v3 v4 ) ( d ) * ( d e v3 v4 ) ( e d ) * ( d e v4 ) ( v1 e d ) * ( d e ) ( v1 v2 e d ) * ( d ) ( v1 v2 v3 e d ) * * where d and e denote diagonal and off-diagonal elements of T, and vi * denotes an element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. 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 ) ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I COMPLEX*16 ALPHA, TAUI * .. * .. External Subroutines .. EXTERNAL XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG * .. * .. External Functions .. LOGICAL LSAME COMPLEX*16 ZDOTC EXTERNAL LSAME, ZDOTC * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHETD2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * IF( UPPER ) THEN * * Reduce the upper triangle of A * A( N, N ) = DBLE( A( N, N ) ) DO 10 I = N - 1, 1, -1 * * Generate elementary reflector H(i) = I - tau * v * v' * to annihilate A(1:i-1,i+1) * ALPHA = A( I, I+1 ) CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI ) E( I ) = ALPHA * IF( TAUI.NE.ZERO ) THEN * * Apply H(i) from both sides to A(1:i,1:i) * A( I, I+1 ) = ONE * * Compute x := tau * A * v storing x in TAU(1:i) * CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, $ TAU, 1 ) * * Compute w := x - 1/2 * tau * (x'*v) * v * ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 ) CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) * * Apply the transformation as a rank-2 update: * A := A - v * w' - w * v' * CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, $ LDA ) * ELSE A( I, I ) = DBLE( A( I, I ) ) END IF A( I, I+1 ) = E( I ) D( I+1 ) = A( I+1, I+1 ) TAU( I ) = TAUI 10 CONTINUE D( 1 ) = A( 1, 1 ) ELSE * * Reduce the lower triangle of A * A( 1, 1 ) = DBLE( A( 1, 1 ) ) DO 20 I = 1, N - 1 * * Generate elementary reflector H(i) = I - tau * v * v' * to annihilate A(i+2:n,i) * ALPHA = A( I+1, I ) CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI ) E( I ) = ALPHA * IF( TAUI.NE.ZERO ) THEN * * Apply H(i) from both sides to A(i+1:n,i+1:n) * A( I+1, I ) = ONE * * Compute x := tau * A * v storing y in TAU(i:n-1) * CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) * * Compute w := x - 1/2 * tau * (x'*v) * v * ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ), $ 1 ) CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) * * Apply the transformation as a rank-2 update: * A := A - v * w' - w * v' * CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, $ A( I+1, I+1 ), LDA ) * ELSE A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) ) END IF A( I+1, I ) = E( I ) D( I ) = A( I, I ) TAU( I ) = TAUI 20 CONTINUE D( N ) = A( N, N ) END IF * RETURN * * End of ZHETD2 * END SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZHETRD reduces a complex Hermitian matrix A to real symmetric * tridiagonal form T by a unitary similarity transformation: * Q**H * A * Q = T. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the Hermitian matrix A. If UPLO = 'U', the leading * N-by-N upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading N-by-N lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * On exit, if UPLO = 'U', the diagonal and first superdiagonal * of A are overwritten by the corresponding elements of the * tridiagonal matrix T, and the elements above the first * superdiagonal, with the array TAU, represent the unitary * matrix Q as a product of elementary reflectors; if UPLO * = 'L', the diagonal and first subdiagonal of A are over- * written by the corresponding elements of the tridiagonal * matrix T, and the elements below the first subdiagonal, with * the array TAU, represent the unitary matrix Q as a product * of elementary reflectors. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * D (output) DOUBLE PRECISION array, dimension (N) * The diagonal elements of the tridiagonal matrix T: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (N-1) * The off-diagonal elements of the tridiagonal matrix T: * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. * * TAU (output) COMPLEX*16 array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= 1. * For optimum performance LWORK >= N*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * If UPLO = 'U', the matrix Q is represented as a product of elementary * reflectors * * Q = H(n-1) . . . H(2) H(1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in * A(1:i-1,i+1), and tau in TAU(i). * * If UPLO = 'L', the matrix Q is represented as a product of elementary * reflectors * * Q = H(1) H(2) . . . H(n-1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), * and tau in TAU(i). * * The contents of A on exit are illustrated by the following examples * with n = 5: * * if UPLO = 'U': if UPLO = 'L': * * ( d e v2 v3 v4 ) ( d ) * ( d e v3 v4 ) ( e d ) * ( d e v4 ) ( v1 e d ) * ( d e ) ( v1 v2 e d ) * ( d ) ( v1 v2 v3 e d ) * * where d and e denote diagonal and off-diagonal elements of T, and vi * denotes an element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZHER2K, ZHETD2, ZLATRD * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN INFO = -9 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size. * NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHETRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NX = N IWS = 1 IF( NB.GT.1 .AND. NB.LT.N ) THEN * * Determine when to cross over from blocked to unblocked code * (last block is always handled by unblocked code). * NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) ) IF( NX.LT.N ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of * unblocked code by setting NX = N. * NB = MAX( LWORK / LDWORK, 1 ) NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 ) IF( NB.LT.NBMIN ) $ NX = N END IF ELSE NX = N END IF ELSE NB = 1 END IF * IF( UPPER ) THEN * * Reduce the upper triangle of A. * Columns 1:kk are handled by the unblocked method. * KK = N - ( ( N-NX+NB-1 ) / NB )*NB DO 20 I = N - NB + 1, KK + 1, -NB * * Reduce columns i:i+nb-1 to tridiagonal form and form the * matrix W which is needed to update the unreduced part of * the matrix * CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, $ LDWORK ) * * Update the unreduced submatrix A(1:i-1,1:i-1), using an * update of the form: A := A - V*W' - W*V' * CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE, $ A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA ) * * Copy superdiagonal elements back into A, and diagonal * elements into D * DO 10 J = I, I + NB - 1 A( J-1, J ) = E( J-1 ) D( J ) = A( J, J ) 10 CONTINUE 20 CONTINUE * * Use unblocked code to reduce the last or only block * CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) ELSE * * Reduce the lower triangle of A * DO 40 I = 1, N - NX, NB * * Reduce columns i:i+nb-1 to tridiagonal form and form the * matrix W which is needed to update the unreduced part of * the matrix * CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), $ TAU( I ), WORK, LDWORK ) * * Update the unreduced submatrix A(i+nb:n,i+nb:n), using * an update of the form: A := A - V*W' - W*V' * CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE, $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, $ A( I+NB, I+NB ), LDA ) * * Copy subdiagonal elements back into A, and diagonal * elements into D * DO 30 J = I, I + NB - 1 A( J+1, J ) = E( J ) D( J ) = A( J, J ) 30 CONTINUE 40 CONTINUE * * Use unblocked code to reduce the last or only block * CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), $ TAU( I ), IINFO ) END IF * WORK( 1 ) = LWKOPT RETURN * * End of ZHETRD * END SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ WORK, LWORK, INFO ) * * -- LAPACK driver routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N CHARACTER COMPZ, JOB * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * Purpose * ======= * * ZHSEQR computes the eigenvalues of a Hessenberg matrix H * and, optionally, the matrices T and Z from the Schur decomposition * H = Z T Z**H, where T is an upper triangular matrix (the * Schur form), and Z is the unitary matrix of Schur vectors. * * Optionally Z may be postmultiplied into an input unitary * matrix Q so that this routine can give the Schur factorization * of a matrix A which has been reduced to the Hessenberg form H * by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. * * Arguments * ========= * * JOB (input) CHARACTER*1 * = 'E': compute eigenvalues only; * = 'S': compute eigenvalues and the Schur form T. * * COMPZ (input) CHARACTER*1 * = 'N': no Schur vectors are computed; * = 'I': Z is initialized to the unit matrix and the matrix Z * of Schur vectors of H is returned; * = 'V': Z must contain an unitary matrix Q on entry, and * the product Q*Z is returned. * * N (input) INTEGER * The order of the matrix H. N .GE. 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that H is already upper triangular in rows * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally * set by a previous call to ZGEBAL, and then passed to ZGEHRD * when the matrix output by ZGEBAL is reduced to Hessenberg * form. Otherwise ILO and IHI should be set to 1 and N * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. * If N = 0, then ILO = 1 and IHI = 0. * * H (input/output) COMPLEX*16 array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. * On exit, if INFO = 0 and JOB = 'S', H contains the upper * triangular matrix T from the Schur decomposition (the * Schur form). If INFO = 0 and JOB = 'E', the contents of * H are unspecified on exit. (The output value of H when * INFO.GT.0 is given under the description of INFO below.) * * Unlike earlier versions of ZHSEQR, this subroutine may * explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 * or j = IHI+1, IHI+2, ... N. * * LDH (input) INTEGER * The leading dimension of the array H. LDH .GE. max(1,N). * * W (output) COMPLEX*16 array, dimension (N) * The computed eigenvalues. If JOB = 'S', the eigenvalues are * stored in the same order as on the diagonal of the Schur * form returned in H, with W(i) = H(i,i). * * Z (input/output) COMPLEX*16 array, dimension (LDZ,N) * If COMPZ = 'N', Z is not referenced. * If COMPZ = 'I', on entry Z need not be set and on exit, * if INFO = 0, Z contains the unitary matrix Z of the Schur * vectors of H. If COMPZ = 'V', on entry Z must contain an * N-by-N matrix Q, which is assumed to be equal to the unit * matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, * if INFO = 0, Z contains Q*Z. * Normally Q is the unitary matrix generated by ZUNGHR * after the call to ZGEHRD which formed the Hessenberg matrix * H. (The output value of Z when INFO.GT.0 is given under * the description of INFO below.) * * LDZ (input) INTEGER * The leading dimension of the array Z. if COMPZ = 'I' or * COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns an estimate of * the optimal value for LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK .GE. max(1,N) * is sufficient, but LWORK typically as large as 6*N may * be required for optimal performance. A workspace query * to determine the optimal workspace size is recommended. * * If LWORK = -1, then ZHSEQR does a workspace query. * In this case, ZHSEQR checks the input parameters and * estimates the optimal workspace size for the given * values of N, ILO and IHI. The estimate is returned * in WORK(1). No error message related to LWORK is * issued by XERBLA. Neither H nor Z are accessed. * * * INFO (output) INTEGER * = 0: successful exit * .LT. 0: if INFO = -i, the i-th argument had an illegal * value * .GT. 0: if INFO = i, ZHSEQR failed to compute all of * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR * and WI contain those eigenvalues which have been * successfully computed. (Failures are rare.) * * If INFO .GT. 0 and JOB = 'E', then on exit, the * remaining unconverged eigenvalues are the eigen- * values of the upper Hessenberg matrix rows and * columns ILO through INFO of the final, output * value of H. * * If INFO .GT. 0 and JOB = 'S', then on exit * * (*) (initial value of H)*U = U*(final value of H) * * where U is a unitary matrix. The final * value of H is upper Hessenberg and triangular in * rows and columns INFO+1 through IHI. * * If INFO .GT. 0 and COMPZ = 'V', then on exit * * (final value of Z) = (initial value of Z)*U * * where U is the unitary matrix in (*) (regard- * less of the value of JOB.) * * If INFO .GT. 0 and COMPZ = 'I', then on exit * (final value of Z) = U * where U is the unitary matrix in (*) (regard- * less of the value of JOB.) * * If INFO .GT. 0 and COMPZ = 'N', then Z is not * accessed. * * ================================================================ * Default values supplied by * ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). * It is suggested that these defaults be adjusted in order * to attain best performance in each particular * computational environment. * * ISPEC=1: The ZLAHQR vs ZLAQR0 crossover point. * Default: 75. (Must be at least 11.) * * ISPEC=2: Recommended deflation window size. * This depends on ILO, IHI and NS. NS is the * number of simultaneous shifts returned * by ILAENV(ISPEC=4). (See ISPEC=4 below.) * The default for (IHI-ILO+1).LE.500 is NS. * The default for (IHI-ILO+1).GT.500 is 3*NS/2. * * ISPEC=3: Nibble crossover point. (See ILAENV for * details.) Default: 14% of deflation window * size. * * ISPEC=4: Number of simultaneous shifts, NS, in * a multi-shift QR iteration. * * If IHI-ILO+1 is ... * * greater than ...but less ... the * or equal to ... than default is * * 1 30 NS - 2(+) * 30 60 NS - 4(+) * 60 150 NS = 10(+) * 150 590 NS = ** * 590 3000 NS = 64 * 3000 6000 NS = 128 * 6000 infinity NS = 256 * * (+) By default some or all matrices of this order * are passed to the implicit double shift routine * ZLAHQR and NS is ignored. See ISPEC=1 above * and comments in IPARM for details. * * The asterisks (**) indicate an ad-hoc * function of N increasing from 10 to 64. * * ISPEC=5: Select structured matrix multiply. * (See ILAENV for details.) Default: 3. * * ================================================================ * Based on contributions by * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * * ================================================================ * References: * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 * Performance, SIAM Journal of Matrix Analysis, volume 23, pages * 929--947, 2002. * * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR * Algorithm Part II: Aggressive Early Deflation, SIAM Journal * of Matrix Analysis, volume 23, pages 948--973, 2002. * * ================================================================ * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . ZLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== * * ==== NL allocates some local workspace to help small matrices * . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is * . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom- * . mended. (The default value of NMIN is 75.) Using NL = 49 * . allows up to six simultaneous shifts and a 16-by-16 * . deflation window. ==== * INTEGER NTINY PARAMETER ( NTINY = 11 ) INTEGER NL PARAMETER ( NL = 49 ) COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION RZERO PARAMETER ( RZERO = 0.0d0 ) * .. * .. Local Arrays .. COMPLEX*16 HL( NL, NL ), WORKL( NL ) * .. * .. Local Scalars .. INTEGER KBOT, NMIN LOGICAL INITZ, LQUERY, WANTT, WANTZ * .. * .. External Functions .. INTEGER ILAENV LOGICAL LSAME EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, MAX, MIN * .. * .. Executable Statements .. * * ==== Decode and check the input parameters. ==== * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO ) LQUERY = LWORK.EQ.-1 * INFO = 0 IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.NE.0 ) THEN * * ==== Quick return in case of invalid argument. ==== * CALL XERBLA( 'ZHSEQR', -INFO ) RETURN * ELSE IF( N.EQ.0 ) THEN * * ==== Quick return in case N = 0; nothing to do. ==== * RETURN * ELSE IF( LQUERY ) THEN * * ==== Quick return in case of a workspace query ==== * CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z, $ LDZ, WORK, LWORK, INFO ) * ==== Ensure reported workspace size is backward-compatible with * . previous LAPACK versions. ==== WORK( 1 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1, $ N ) ) ), RZERO ) RETURN * ELSE * * ==== copy eigenvalues isolated by ZGEBAL ==== * IF( ILO.GT.1 ) $ CALL ZCOPY( ILO-1, H, LDH+1, W, 1 ) IF( IHI.LT.N ) $ CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 ) * * ==== Initialize Z, if requested ==== * IF( INITZ ) $ CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) * * ==== Quick return if possible ==== * IF( ILO.EQ.IHI ) THEN W( ILO ) = H( ILO, ILO ) RETURN END IF * * ==== ZLAHQR/ZLAQR0 crossover point ==== * NMIN = ILAENV( 1, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO, $ IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== * IF( N.GT.NMIN ) THEN CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, $ Z, LDZ, WORK, LWORK, INFO ) ELSE * * ==== Small matrix ==== * CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, $ Z, LDZ, INFO ) * IF( INFO.GT.0 ) THEN * * ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds * . when ZLAHQR fails. ==== * KBOT = INFO * IF( N.GE.NL ) THEN * * ==== Larger matrices have enough subdiagonal scratch * . space to call ZLAQR0 directly. ==== * CALL ZLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W, $ ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) * ELSE * * ==== Tiny matrices don't have enough subdiagonal * . scratch space to benefit from ZLAQR0. Hence, * . tiny matrices must be copied into a larger * . array before calling ZLAQR0. ==== * CALL ZLACPY( 'A', N, N, H, LDH, HL, NL ) HL( N+1, N ) = ZERO CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), $ NL ) CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W, $ ILO, IHI, Z, LDZ, WORKL, NL, INFO ) IF( WANTT .OR. INFO.NE.0 ) $ CALL ZLACPY( 'A', N, N, HL, NL, H, LDH ) END IF END IF END IF * * ==== Clear out the trash, if necessary. ==== * IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) $ CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) * * ==== Ensure reported workspace size is backward-compatible with * . previous LAPACK versions. ==== * WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ), $ DBLE( WORK( 1 ) ) ), RZERO ) END IF * * ==== End of ZHSEQR ==== * END SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ), $ Y( LDY, * ) * .. * * Purpose * ======= * * ZLABRD reduces the first NB rows and columns of a complex general * m by n matrix A to upper or lower real bidiagonal form by a unitary * transformation Q' * A * P, and returns the matrices X and Y which * are needed to apply the transformation to the unreduced part of A. * * If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower * bidiagonal form. * * This is an auxiliary routine called by ZGEBRD * * Arguments * ========= * * M (input) INTEGER * The number of rows in the matrix A. * * N (input) INTEGER * The number of columns in the matrix A. * * NB (input) INTEGER * The number of leading rows and columns of A to be reduced. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n general matrix to be reduced. * On exit, the first NB rows and columns of the matrix are * overwritten; the rest of the array is unchanged. * If m >= n, elements on and below the diagonal in the first NB * columns, with the array TAUQ, represent the unitary * matrix Q as a product of elementary reflectors; and * elements above the diagonal in the first NB rows, with the * array TAUP, represent the unitary matrix P as a product * of elementary reflectors. * If m < n, elements below the diagonal in the first NB * columns, with the array TAUQ, represent the unitary * matrix Q as a product of elementary reflectors, and * elements on and above the diagonal in the first NB rows, * with the array TAUP, represent the unitary matrix P as * a product of elementary reflectors. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * D (output) DOUBLE PRECISION array, dimension (NB) * The diagonal elements of the first NB rows and columns of * the reduced matrix. D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (NB) * The off-diagonal elements of the first NB rows and columns of * the reduced matrix. * * TAUQ (output) COMPLEX*16 array dimension (NB) * The scalar factors of the elementary reflectors which * represent the unitary matrix Q. See Further Details. * * TAUP (output) COMPLEX*16 array, dimension (NB) * The scalar factors of the elementary reflectors which * represent the unitary matrix P. See Further Details. * * X (output) COMPLEX*16 array, dimension (LDX,NB) * The m-by-nb matrix X required to update the unreduced part * of A. * * LDX (input) INTEGER * The leading dimension of the array X. LDX >= max(1,M). * * Y (output) COMPLEX*16 array, dimension (LDY,NB) * The n-by-nb matrix Y required to update the unreduced part * of A. * * LDY (input) INTEGER * The leading dimension of the array Y. LDY >= max(1,N). * * Further Details * =============== * * The matrices Q and P are represented as products of elementary * reflectors: * * Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are complex scalars, and v and u are complex * vectors. * * If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in * A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). * * If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in * A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). * * The elements of the vectors v and u together form the m-by-nb matrix * V and the nb-by-n matrix U' which are needed, with X and Y, to apply * the transformation to the unreduced part of the matrix, using a block * update of the form: A := A - V*Y' - X*U'. * * The contents of A on exit are illustrated by the following examples * with nb = 2: * * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): * * ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) * ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) * ( v1 v2 a a a ) ( v1 1 a a a a ) * ( v1 v2 a a a ) ( v1 v2 a a a a ) * ( v1 v2 a a a ) ( v1 v2 a a a a ) * ( v1 v2 a a a ) * * where a denotes an element of the original matrix which is unchanged, * vi denotes an element of the vector defining H(i), and ui an element * of the vector defining G(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL ZGEMV, ZLACGV, ZLARFG, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, NB * * Update A(i:m,i) * CALL ZLACGV( I-1, Y( I, 1 ), LDY ) CALL ZGEMV( '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 ZGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) * * Generate reflection Q(i) to annihilate A(i+1:m,i) * 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 * * Compute Y(i+1:n,i) * CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I, ONE, $ A( I, I+1 ), LDA, A( I, I ), 1, ZERO, $ Y( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE, $ A( I, 1 ), LDA, A( I, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE, $ X( I, 1 ), LDX, A( I, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE, $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE, $ Y( I+1, I ), 1 ) CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) * * Update A(i,i+1:n) * CALL ZLACGV( N-I, A( I, I+1 ), LDA ) CALL ZLACGV( I, A( I, 1 ), LDA ) CALL ZGEMV( '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 ZGEMV( '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 ) * * Generate reflection P(i) to annihilate A(i,i+2:n) * 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 * * Compute X(i+1:m,i) * CALL ZGEMV( '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 ZGEMV( 'Conjugate transpose', N-I, I, ONE, $ Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO, $ X( 1, I ), 1 ) CALL ZGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) CALL ZLACGV( N-I, A( I, I+1 ), LDA ) END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, NB * * Update A(i,i:n) * CALL ZLACGV( N-I+1, A( I, I ), LDA ) CALL ZLACGV( I-1, A( I, 1 ), LDA ) CALL ZGEMV( '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 ZGEMV( '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 ) * * Generate reflection P(i) to annihilate A(i,i+1:n) * 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 * * Compute X(i+1:m,i) * CALL ZGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, ONE, $ Y( I, 1 ), LDY, A( I, I ), LDA, ZERO, $ X( 1, I ), 1 ) CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL ZGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) CALL ZLACGV( N-I+1, A( I, I ), LDA ) * * Update A(i+1:m,i) * CALL ZLACGV( I-1, Y( I, 1 ), LDY ) CALL ZGEMV( '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 ZGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) * * Generate reflection Q(i) to annihilate A(i+2:m,i) * 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 * * Compute Y(i+1:n,i) * CALL ZGEMV( '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 ZGEMV( 'Conjugate transpose', M-I, I-1, ONE, $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', M-I, I, ONE, $ X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', I, N-I, -ONE, $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE, $ Y( I+1, I ), 1 ) CALL ZSCAL( 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 of ZLABRD * END SUBROUTINE ZLACGV( N, X, INCX ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * Purpose * ======= * * ZLACGV conjugates a complex vector of length N. * * Arguments * ========= * * N (input) INTEGER * The length of the vector X. N >= 0. * * X (input/output) COMPLEX*16 array, dimension * (1+(N-1)*abs(INCX)) * On entry, the vector of length N to be conjugated. * On exit, X is overwritten with conjg(X). * * INCX (input) INTEGER * The spacing between successive elements of X. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IOFF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * IF( INCX.EQ.1 ) THEN DO 10 I = 1, N X( I ) = DCONJG( X( I ) ) 10 CONTINUE ELSE IOFF = 1 IF( INCX.LT.0 ) $ IOFF = 1 - ( N-1 )*INCX DO 20 I = 1, N X( IOFF ) = DCONJG( X( IOFF ) ) IOFF = IOFF + INCX 20 CONTINUE END IF RETURN * * End of ZLACGV * END SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER KASE, N DOUBLE PRECISION EST * .. * .. Array Arguments .. INTEGER ISAVE( 3 ) COMPLEX*16 V( * ), X( * ) * .. * * Purpose * ======= * * ZLACN2 estimates the 1-norm of a square, complex matrix A. * Reverse communication is used for evaluating matrix-vector products. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix. N >= 1. * * V (workspace) COMPLEX*16 array, dimension (N) * On the final return, V = A*W, where EST = norm(V)/norm(W) * (W is not returned). * * X (input/output) COMPLEX*16 array, dimension (N) * On an intermediate return, X should be overwritten by * A * X, if KASE=1, * A' * X, if KASE=2, * where A' is the conjugate transpose of A, and ZLACN2 must be * re-called with all the other parameters unchanged. * * EST (input/output) DOUBLE PRECISION * On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be * unchanged from the previous call to ZLACN2. * On exit, EST is an estimate (a lower bound) for norm(A). * * KASE (input/output) INTEGER * On the initial call to ZLACN2, KASE should be 0. * On an intermediate return, KASE will be 1 or 2, indicating * whether X should be overwritten by A * X or A' * X. * On the final return from ZLACN2, KASE will again be 0. * * ISAVE (input/output) INTEGER array, dimension (3) * ISAVE is used to save variables between calls to ZLACN2 * * Further Details * ======= ======= * * Contributed by Nick Higham, University of Manchester. * Originally named CONEST, dated March 16, 1988. * * Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of * a real or complex matrix, with applications to condition estimation", * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. * * Last modified: April, 1999 * * This is a thread safe version of ZLACON, which uses the array ISAVE * in place of a SAVE statement, as follows: * * ZLACON ZLACN2 * JUMP ISAVE(1) * J ISAVE(2) * ITER ISAVE(3) * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) * .. * .. Local Scalars .. INTEGER I, JLAST DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP * .. * .. External Functions .. INTEGER IZMAX1 DOUBLE PRECISION DLAMCH, DZSUM1 EXTERNAL IZMAX1, DLAMCH, DZSUM1 * .. * .. External Subroutines .. EXTERNAL ZCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG * .. * .. Executable Statements .. * SAFMIN = DLAMCH( 'Safe minimum' ) IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = DCMPLX( ONE / DBLE( N ) ) 10 CONTINUE KASE = 1 ISAVE( 1 ) = 1 RETURN END IF * GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 ) * * ................ ENTRY (ISAVE( 1 ) = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 130 END IF EST = DZSUM1( N, X, 1 ) * DO 30 I = 1, N ABSXI = ABS( X( I ) ) IF( ABSXI.GT.SAFMIN ) THEN X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, $ DIMAG( X( I ) ) / ABSXI ) ELSE X( I ) = CONE END IF 30 CONTINUE KASE = 2 ISAVE( 1 ) = 2 RETURN * * ................ ENTRY (ISAVE( 1 ) = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 40 CONTINUE ISAVE( 2 ) = IZMAX1( N, X, 1 ) ISAVE( 3 ) = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = CZERO 60 CONTINUE X( ISAVE( 2 ) ) = CONE KASE = 1 ISAVE( 1 ) = 3 RETURN * * ................ ENTRY (ISAVE( 1 ) = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL ZCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = DZSUM1( N, V, 1 ) * * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 100 * DO 80 I = 1, N ABSXI = ABS( X( I ) ) IF( ABSXI.GT.SAFMIN ) THEN X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, $ DIMAG( X( I ) ) / ABSXI ) ELSE X( I ) = CONE END IF 80 CONTINUE KASE = 2 ISAVE( 1 ) = 4 RETURN * * ................ ENTRY (ISAVE( 1 ) = 4) * X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 90 CONTINUE JLAST = ISAVE( 2 ) ISAVE( 2 ) = IZMAX1( N, X, 1 ) IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN ISAVE( 3 ) = ISAVE( 3 ) + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 100 CONTINUE ALTSGN = ONE DO 110 I = 1, N X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ) ALTSGN = -ALTSGN 110 CONTINUE KASE = 1 ISAVE( 1 ) = 5 RETURN * * ................ ENTRY (ISAVE( 1 ) = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 120 CONTINUE TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL ZCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 130 CONTINUE KASE = 0 RETURN * * End of ZLACN2 * END SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, LDB, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZLACPY copies all or part of a two-dimensional matrix A to another * matrix B. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be copied to B. * = 'U': Upper triangular part * = 'L': Lower triangular part * Otherwise: All of the matrix A * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The m by n matrix A. If UPLO = 'U', only the upper trapezium * is accessed; if UPLO = 'L', only the lower trapezium is * accessed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (output) COMPLEX*16 array, dimension (LDB,N) * On exit, B = A in the locations specified by UPLO. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE * ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF * RETURN * * End of ZLACPY * END COMPLEX*16 FUNCTION ZLADIV( X, Y ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. COMPLEX*16 X, Y * .. * * Purpose * ======= * * ZLADIV := X / Y, where X and Y are complex. The computation of X / Y * will not overflow on an intermediary step unless the results * overflows. * * Arguments * ========= * * X (input) COMPLEX*16 * Y (input) COMPLEX*16 * The complex scalars X and Y. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION ZI, ZR * .. * .. External Subroutines .. EXTERNAL DLADIV * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, DIMAG * .. * .. Executable Statements .. * CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR, $ ZI ) ZLADIV = DCMPLX( ZR, ZI ) * RETURN * * End of ZLADIV * END SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * ZLAHQR is an auxiliary routine called by CHSEQR to update the * eigenvalues and Schur decomposition already computed by CHSEQR, by * dealing with the Hessenberg submatrix in rows and columns ILO to * IHI. * * Arguments * ========= * * WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * * WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * * N (input) INTEGER * The order of the matrix H. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that H is already upper triangular in rows and * columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). * ZLAHQR works primarily with the Hessenberg submatrix in rows * and columns ILO to IHI, but applies transformations to all of * H if WANTT is .TRUE.. * 1 <= ILO <= max(1,IHI); IHI <= N. * * H (input/output) COMPLEX*16 array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. * On exit, if INFO is zero and if WANTT is .TRUE., then H * is upper triangular in rows and columns ILO:IHI. If INFO * is zero and if WANTT is .FALSE., then the contents of H * are unspecified on exit. The output state of H in case * INF is positive is below under the description of INFO. * * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * * W (output) COMPLEX*16 array, dimension (N) * The computed eigenvalues ILO to IHI are stored in the * corresponding elements of W. If WANTT is .TRUE., the * eigenvalues are stored in the same order as on the diagonal * of the Schur form returned in H, with W(i) = H(i,i). * * ILOZ (input) INTEGER * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. * * Z (input/output) COMPLEX*16 array, dimension (LDZ,N) * If WANTZ is .TRUE., on entry Z must contain the current * matrix Z of transformations accumulated by CHSEQR, and on * exit Z has been updated; transformations are applied only to * the submatrix Z(ILOZ:IHIZ,ILO:IHI). * If WANTZ is .FALSE., Z is not referenced. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * .GT. 0: if INFO = i, ZLAHQR failed to compute all the * eigenvalues ILO to IHI in a total of 30 iterations * per eigenvalue; elements i+1:ihi of W contain * those eigenvalues which have been successfully * computed. * * If INFO .GT. 0 and WANTT is .FALSE., then on exit, * the remaining unconverged eigenvalues are the * eigenvalues of the upper Hessenberg matrix * rows and columns ILO thorugh INFO of the final, * output value of H. * * If INFO .GT. 0 and WANTT is .TRUE., then on exit * (*) (initial value of H)*U = U*(final value of H) * where U is an orthognal matrix. The final * value of H is upper Hessenberg and triangular in * rows and columns INFO+1 through IHI. * * If INFO .GT. 0 and WANTZ is .TRUE., then on exit * (final value of Z) = (initial value of Z)*U * where U is the orthogonal matrix in (*) * (regardless of the value of WANTT.) * * Further Details * =============== * * 02-96 Based on modifications by * David Day, Sandia National Laboratory, USA * * 12-04 Further modifications by * Ralph Byers, University of Kansas, USA * * This is a modified version of ZLAHQR from LAPACK version 3.0. * It is (1) more robust against overflow and underflow and * (2) adopts the more conservative Ahues & Tisseur stopping * criterion (LAWN 122, 1997). * * ========================================================= * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 30 ) COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION RZERO, RONE, HALF PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 ) DOUBLE PRECISION DAT1 PARAMETER ( DAT1 = 3.0d0 / 4.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U, $ V2, X, Y DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX, $ SAFMIN, SMLNUM, SX, T2, TST, ULP INTEGER I, I1, I2, ITS, J, JHI, JLO, K, L, M, NH, NZ * .. * .. Local Arrays .. COMPLEX*16 V( 2 ) * .. * .. External Functions .. COMPLEX*16 ZLADIV DOUBLE PRECISION DLAMCH EXTERNAL ZLADIV, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( ILO.EQ.IHI ) THEN W( ILO ) = H( ILO, ILO ) RETURN END IF * * ==== clear out the trash ==== DO 10 J = ILO, IHI - 3 H( J+2, J ) = ZERO H( J+3, J ) = ZERO 10 CONTINUE IF( ILO.LE.IHI-2 ) $ H( IHI, IHI-2 ) = ZERO * ==== ensure that subdiagonal entries are real ==== DO 20 I = ILO + 1, IHI IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN * ==== The following redundant normalization * . avoids problems with both gradual and * . sudden underflow in ABS(H(I,I-1)) ==== SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) SC = DCONJG( SC ) / ABS( SC ) H( I, I-1 ) = ABS( H( I, I-1 ) ) IF( WANTT ) THEN JLO = 1 JHI = N ELSE JLO = ILO JHI = IHI END IF CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH ) CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ), $ H( JLO, I ), 1 ) IF( WANTZ ) $ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 ) END IF 20 CONTINUE * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are * being computed, I1 and I2 are set inside the main loop. * IF( WANTT ) THEN I1 = 1 I2 = N END IF * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1. Each iteration of the loop works * with the active submatrix in rows and columns L to I. * Eigenvalues I+1 to IHI have already converged. Either L = ILO, or * H(L,L-1) is negligible so that the matrix splits. * I = IHI 30 CONTINUE IF( I.LT.ILO ) $ GO TO 150 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 splits off at the bottom because a * subdiagonal element has become negligible. * L = ILO DO 130 ITS = 0, ITMAX * * Look for a single small subdiagonal element. * DO 40 K = I, L + 1, -1 IF( CABS1( H( K, K-1 ) ).LE.SMLNUM ) $ GO TO 50 TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) IF( TST.EQ.ZERO ) THEN IF( K-2.GE.ILO ) $ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) ) IF( K+1.LE.IHI ) $ TST = TST + ABS( DBLE( H( K+1, K ) ) ) END IF * ==== The following is a conservative small subdiagonal * . deflation criterion due to Ahues & Tisseur (LAWN 122, * . 1997). It has better mathematical foundation and * . improves accuracy in some examples. ==== IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) AA = MAX( CABS1( H( K, K ) ), $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) BB = MIN( CABS1( H( K, K ) ), $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) S = AA + AB IF( BA*( AB / S ).LE.MAX( SMLNUM, $ ULP*( BB*( AA / S ) ) ) )GO TO 50 END IF 40 CONTINUE 50 CONTINUE L = K IF( L.GT.ILO ) THEN * * H(L,L-1) is negligible * H( L, L-1 ) = ZERO END IF * * Exit from loop if a submatrix of order 1 has split off. * IF( L.GE.I ) $ GO TO 140 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix * need be transformed. * IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF * IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN * * Exceptional shift. * S = DAT1*ABS( DBLE( H( I, I-1 ) ) ) T = S + H( I, I ) ELSE * * Wilkinson's shift. * T = H( I, I ) U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) ) S = CABS1( U ) IF( S.NE.RZERO ) THEN X = HALF*( H( I-1, I-1 )-T ) SX = CABS1( X ) S = MAX( S, CABS1( X ) ) Y = S*SQRT( ( X / S )**2+( U / S )**2 ) IF( SX.GT.RZERO ) THEN IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )* $ DIMAG( Y ).LT.RZERO )Y = -Y END IF T = T - U*ZLADIV( U, ( X+Y ) ) END IF END IF * * Look for two consecutive small subdiagonal elements. * DO 60 M = I - 1, L + 1, -1 * * Determine the effect of starting the single-shift QR * iteration at row M, and see if this would make H(M,M-1) * negligible. * H11 = H( M, M ) H22 = H( M+1, M+1 ) H11S = H11 - T H21 = H( M+1, M ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 H10 = H( M, M-1 ) IF( ABS( H10 )*ABS( H21 ).LE.ULP* $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) $ GO TO 70 60 CONTINUE H11 = H( L, L ) H22 = H( L+1, L+1 ) H11S = H11 - T H21 = H( L+1, L ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 70 CONTINUE * * Single-shift QR step * DO 120 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, * thus creating a nonzero bulge below the subdiagonal. * * Each subsequent iteration determines a reflection G to * restore the Hessenberg form in the (K-1)th column, and thus * chases the bulge one step toward the bottom of the active * submatrix. * * V(2) is always real before the call to ZLARFG, and hence * after the call T2 ( = T1*V(2) ) is also real. * IF( K.GT.M ) $ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 ) CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 ) IF( K.GT.M ) THEN H( K, K-1 ) = V( 1 ) H( K+1, K-1 ) = ZERO END IF V2 = V( 2 ) T2 = DBLE( T1*V2 ) * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 80 J = K, I2 SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM H( K+1, J ) = H( K+1, J ) - SUM*V2 80 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+2,I). * DO 90 J = I1, MIN( K+2, I ) SUM = T1*H( J, K ) + T2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 ) 90 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 100 J = ILOZ, IHIZ SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 ) 100 CONTINUE END IF * IF( K.EQ.M .AND. M.GT.L ) THEN * * If the QR step was started at row M > L because two * consecutive small subdiagonals were found, then extra * scaling must be performed to ensure that H(M,M-1) remains * real. * TEMP = ONE - T1 TEMP = TEMP / ABS( TEMP ) H( M+1, M ) = H( M+1, M )*DCONJG( TEMP ) IF( M+2.LE.I ) $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP DO 110 J = M, I IF( J.NE.M+1 ) THEN IF( I2.GT.J ) $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 ) IF( WANTZ ) THEN CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ), $ 1 ) END IF END IF 110 CONTINUE END IF 120 CONTINUE * * Ensure that H(I,I-1) is real. * TEMP = H( I, I-1 ) IF( DIMAG( TEMP ).NE.RZERO ) THEN RTEMP = ABS( TEMP ) H( I, I-1 ) = RTEMP TEMP = TEMP / RTEMP IF( I2.GT.I ) $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH ) CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 ) IF( WANTZ ) THEN CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 ) END IF END IF * 130 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * 140 CONTINUE * * H(I,I-1) is negligible: one eigenvalue has converged. * W( I ) = H( I, I ) * * return to start of the main loop with new value of I. * I = L - 1 GO TO 30 * 150 CONTINUE RETURN * * End of ZLAHQR * END SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), $ Y( LDY, NB ) * .. * * Purpose * ======= * * ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) * matrix A so that elements below the k-th subdiagonal are zero. The * reduction is performed by an unitary similarity transformation * Q' * A * Q. The routine returns the matrices V and T which determine * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. * * This is an auxiliary routine called by ZGEHRD. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. * * K (input) INTEGER * The offset for the reduction. Elements below the k-th * subdiagonal in the first NB columns are reduced to zero. * K < N. * * NB (input) INTEGER * The number of columns to be reduced. * * A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) * On entry, the n-by-(n-k+1) general matrix A. * On exit, the elements on and above the k-th subdiagonal in * the first NB columns are overwritten with the corresponding * elements of the reduced matrix; the elements below the k-th * subdiagonal, with the array TAU, represent the matrix Q as a * product of elementary reflectors. The other columns of A are * unchanged. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * TAU (output) COMPLEX*16 array, dimension (NB) * The scalar factors of the elementary reflectors. See Further * Details. * * T (output) COMPLEX*16 array, dimension (LDT,NB) * The upper triangular matrix T. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= NB. * * Y (output) COMPLEX*16 array, dimension (LDY,NB) * The n-by-nb matrix Y. * * LDY (input) INTEGER * The leading dimension of the array Y. LDY >= N. * * Further Details * =============== * * The matrix Q is represented as a product of nb elementary reflectors * * Q = H(1) H(2) . . . H(nb). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in * A(i+k+1:n,i), and tau in TAU(i). * * The elements of the vectors v together form the (n-k+1)-by-nb matrix * V which is needed, with T and Y, to apply the transformation to the * unreduced part of the matrix, using an update of the form: * A := (I - V*T*V') * (A - Y*V'). * * The contents of A on exit are illustrated by the following example * with n = 7, k = 3 and nb = 2: * * ( a a a a a ) * ( a a a a a ) * ( a a a a a ) * ( h h a a a ) * ( v1 h a a a ) * ( v1 v2 a a a ) * ( v1 v2 a a a ) * * where a denotes an element of the original matrix A, h denotes a * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * * This file is a slight modification of LAPACK-3.0's ZLAHRD * incorporating improvements proposed by Quintana-Orti and Van de * Gejin. Note that the entries of A(1:K,2:NB) differ from those * returned by the original LAPACK routine. This function is * not backward compatible with LAPACK3.0. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX*16 EI * .. * .. External Subroutines .. EXTERNAL ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY, $ ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.1 ) $ RETURN * DO 10 I = 1, NB IF( I.GT.1 ) THEN * * Update A(K+1:N,I) * * Update I-th column of A - Y * V' * CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) * * Apply I - V * T' * V' to this column (call it b) from the * left, using the last column of T as workspace * * Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) * ( V2 ) ( b2 ) * * where V1 is unit lower triangular * * w := V1' * b1 * CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT', $ I-1, A( K+1, 1 ), $ LDA, T( 1, NB ), 1 ) * * w := w + V2'*b2 * CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, $ ONE, A( K+I, 1 ), $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) * * w := T'*w * CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, NB ), 1 ) * * b2 := b2 - V2*w * CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, $ A( K+I, 1 ), $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) * * b1 := b1 - V1*w * CALL ZTRMV( 'Lower', 'NO TRANSPOSE', $ 'UNIT', I-1, $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) * A( K+I-1, I-1 ) = EI END IF * * Generate the elementary reflector H(I) to annihilate * A(K+I+1:N,I) * CALL ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, $ TAU( I ) ) EI = A( K+I, I ) A( K+I, I ) = ONE * * Compute Y(K+1:N,I) * CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, $ ONE, A( K+1, I+1 ), $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, $ ONE, A( K+I, 1 ), LDA, $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, $ Y( K+1, 1 ), LDY, $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) * * Compute T(1:I,I) * CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) * 10 CONTINUE A( K+NB, NB ) = EI * * Compute Y(1:K,1:NB) * CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', $ 'UNIT', K, NB, $ ONE, A( K+1, 1 ), LDA, Y, LDY ) IF( N.GT.K+NB ) $ CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, $ NB, N-K-NB, ONE, $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, $ LDY ) CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', $ 'NON-UNIT', K, NB, $ ONE, T, LDT, Y, LDY ) * RETURN * * End of ZLAHR2 * END SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), $ Y( LDY, NB ) * .. * * Purpose * ======= * * ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1) * matrix A so that elements below the k-th subdiagonal are zero. The * reduction is performed by a unitary similarity transformation * Q' * A * Q. The routine returns the matrices V and T which determine * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. * * This is an OBSOLETE auxiliary routine. * This routine will be 'deprecated' in a future release. * Please use the new routine ZLAHR2 instead. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. * * K (input) INTEGER * The offset for the reduction. Elements below the k-th * subdiagonal in the first NB columns are reduced to zero. * * NB (input) INTEGER * The number of columns to be reduced. * * A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) * On entry, the n-by-(n-k+1) general matrix A. * On exit, the elements on and above the k-th subdiagonal in * the first NB columns are overwritten with the corresponding * elements of the reduced matrix; the elements below the k-th * subdiagonal, with the array TAU, represent the matrix Q as a * product of elementary reflectors. The other columns of A are * unchanged. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * TAU (output) COMPLEX*16 array, dimension (NB) * The scalar factors of the elementary reflectors. See Further * Details. * * T (output) COMPLEX*16 array, dimension (LDT,NB) * The upper triangular matrix T. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= NB. * * Y (output) COMPLEX*16 array, dimension (LDY,NB) * The n-by-nb matrix Y. * * LDY (input) INTEGER * The leading dimension of the array Y. LDY >= max(1,N). * * Further Details * =============== * * The matrix Q is represented as a product of nb elementary reflectors * * Q = H(1) H(2) . . . H(nb). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in * A(i+k+1:n,i), and tau in TAU(i). * * The elements of the vectors v together form the (n-k+1)-by-nb matrix * V which is needed, with T and Y, to apply the transformation to the * unreduced part of the matrix, using an update of the form: * A := (I - V*T*V') * (A - Y*V'). * * The contents of A on exit are illustrated by the following example * with n = 7, k = 3 and nb = 2: * * ( a h a a a ) * ( a h a a a ) * ( a h a a a ) * ( h h a a a ) * ( v1 h a a a ) * ( v1 v2 a a a ) * ( v1 v2 a a a ) * * where a denotes an element of the original matrix A, h denotes a * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX*16 EI * .. * .. External Subroutines .. EXTERNAL ZAXPY, ZCOPY, ZGEMV, ZLACGV, ZLARFG, ZSCAL, $ ZTRMV * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.1 ) $ RETURN * DO 10 I = 1, NB IF( I.GT.1 ) THEN * * Update A(1:n,i) * * Compute i-th column of A - Y * V' * CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) CALL ZGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, $ A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 ) CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) * * Apply I - V * T' * V' to this column (call it b) from the * left, using the last column of T as workspace * * Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) * ( V2 ) ( b2 ) * * where V1 is unit lower triangular * * w := V1' * b1 * CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) CALL ZTRMV( 'Lower', 'Conjugate transpose', 'Unit', I-1, $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) * * w := w + V2'*b2 * CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, ONE, $ A( K+I, 1 ), LDA, A( K+I, I ), 1, ONE, $ T( 1, NB ), 1 ) * * w := T'*w * CALL ZTRMV( 'Upper', 'Conjugate transpose', 'Non-unit', I-1, $ T, LDT, T( 1, NB ), 1 ) * * b2 := b2 - V2*w * CALL ZGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ), $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) * * b1 := b1 - V1*w * CALL ZTRMV( 'Lower', 'No transpose', 'Unit', I-1, $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) * A( K+I-1, I-1 ) = EI END IF * * Generate the elementary reflector H(i) to annihilate * A(k+i+1:n,i) * EI = A( K+I, I ) CALL ZLARFG( N-K-I+1, EI, A( MIN( K+I+1, N ), I ), 1, $ TAU( I ) ) A( K+I, I ) = ONE * * Compute Y(1:n,i) * CALL ZGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA, $ A( K+I, I ), 1, ZERO, Y( 1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, ONE, $ A( K+I, 1 ), LDA, A( K+I, I ), 1, ZERO, T( 1, I ), $ 1 ) CALL ZGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1, $ ONE, Y( 1, I ), 1 ) CALL ZSCAL( N, TAU( I ), Y( 1, I ), 1 ) * * Compute T(1:i,i) * CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) * 10 CONTINUE A( K+NB, NB ) = EI * RETURN * * End of ZLAHRD * END DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION WORK( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLANGE returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * complex matrix A. * * Description * =========== * * ZLANGE returns the value * * ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in ZLANGE as described * above. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. When M = 0, * ZLANGE is set to zero. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. When N = 0, * ZLANGE is set to zero. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The m by n matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( MIN( M, N ).EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, M VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, M SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, M WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, M VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * ZLANGE = VALUE RETURN * * End of ZLANGE * END DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION WORK( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLANHE returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * complex hermitian matrix A. * * Description * =========== * * ZLANHE returns the value * * ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in ZLANHE as described * above. * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * hermitian matrix A is to be referenced. * = 'U': Upper triangular part of A is referenced * = 'L': Lower triangular part of A is referenced * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, ZLANHE is * set to zero. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The hermitian matrix A. If UPLO = 'U', the leading n by n * upper triangular part of A contains the upper triangular part * of the matrix A, and the strictly lower triangular part of A * is not referenced. If UPLO = 'L', the leading n by n lower * triangular part of A contains the lower triangular part of * the matrix A, and the strictly upper triangular part of A is * not referenced. Note that the imaginary parts of the diagonal * elements need not be set and are assumed to be zero. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, * WORK is not referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, J - 1 VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE VALUE = MAX( VALUE, ABS( DBLE( A( J, J ) ) ) ) 20 CONTINUE ELSE DO 40 J = 1, N VALUE = MAX( VALUE, ABS( DBLE( A( J, J ) ) ) ) DO 30 I = J + 1, N VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 30 CONTINUE 40 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. $ ( NORM.EQ.'1' ) ) THEN * * Find normI(A) ( = norm1(A), since A is hermitian). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N SUM = ZERO DO 50 I = 1, J - 1 ABSA = ABS( A( I, J ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA 50 CONTINUE WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) ) 60 CONTINUE DO 70 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 70 CONTINUE ELSE DO 80 I = 1, N WORK( I ) = ZERO 80 CONTINUE DO 100 J = 1, N SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) ) DO 90 I = J + 1, N ABSA = ABS( A( I, J ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA 90 CONTINUE VALUE = MAX( VALUE, SUM ) 100 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) 110 CONTINUE ELSE DO 120 J = 1, N - 1 CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) 120 CONTINUE END IF SUM = 2*SUM DO 130 I = 1, N IF( DBLE( A( I, I ) ).NE.ZERO ) THEN ABSA = ABS( DBLE( A( I, I ) ) ) IF( SCALE.LT.ABSA ) THEN SUM = ONE + SUM*( SCALE / ABSA )**2 SCALE = ABSA ELSE SUM = SUM + ( ABSA / SCALE )**2 END IF END IF 130 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * ZLANHE = VALUE RETURN * * End of ZLANHE * END DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION WORK( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLANHS returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * Hessenberg matrix A. * * Description * =========== * * ZLANHS returns the value * * ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in ZLANHS as described * above. * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, ZLANHS is * set to zero. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The n by n upper Hessenberg matrix A; the part of A below the * first sub-diagonal is not referenced. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, MIN( N, J+1 ) VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, MIN( N, J+1 ) SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, MIN( N, J+1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * ZLANHS = VALUE RETURN * * End of ZLANHS * END DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION WORK( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLANTR returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * trapezoidal or triangular matrix A. * * Description * =========== * * ZLANTR returns the value * * ZLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in ZLANTR as described * above. * * UPLO (input) CHARACTER*1 * Specifies whether the matrix A is upper or lower trapezoidal. * = 'U': Upper trapezoidal * = 'L': Lower trapezoidal * Note that A is triangular instead of trapezoidal if M = N. * * DIAG (input) CHARACTER*1 * Specifies whether or not the matrix A has unit diagonal. * = 'N': Non-unit diagonal * = 'U': Unit diagonal * * M (input) INTEGER * The number of rows of the matrix A. M >= 0, and if * UPLO = 'U', M <= N. When M = 0, ZLANTR is set to zero. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0, and if * UPLO = 'L', N <= M. When N = 0, ZLANTR is set to zero. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The trapezoidal matrix A (A is triangular if M = N). * If UPLO = 'U', the leading m by n upper trapezoidal part of * the array A contains the upper trapezoidal matrix, and the * strictly lower triangular part of A is not referenced. * If UPLO = 'L', the leading m by n lower trapezoidal part of * the array A contains the lower trapezoidal matrix, and the * strictly upper triangular part of A is not referenced. Note * that when DIAG = 'U', the diagonal elements of A are not * referenced and are assumed to be one. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( MIN( M, N ).EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * IF( LSAME( DIAG, 'U' ) ) THEN VALUE = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( M, J-1 ) VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE DO 40 J = 1, N DO 30 I = J + 1, M VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 30 CONTINUE 40 CONTINUE END IF ELSE VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N DO 50 I = 1, MIN( M, J ) VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 50 CONTINUE 60 CONTINUE ELSE DO 80 J = 1, N DO 70 I = J, M VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 70 CONTINUE 80 CONTINUE END IF END IF ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO UDIAG = LSAME( DIAG, 'U' ) IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 1, N IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN SUM = ONE DO 90 I = 1, J - 1 SUM = SUM + ABS( A( I, J ) ) 90 CONTINUE ELSE SUM = ZERO DO 100 I = 1, MIN( M, J ) SUM = SUM + ABS( A( I, J ) ) 100 CONTINUE END IF VALUE = MAX( VALUE, SUM ) 110 CONTINUE ELSE DO 140 J = 1, N IF( UDIAG ) THEN SUM = ONE DO 120 I = J + 1, M SUM = SUM + ABS( A( I, J ) ) 120 CONTINUE ELSE SUM = ZERO DO 130 I = J, M SUM = SUM + ABS( A( I, J ) ) 130 CONTINUE END IF VALUE = MAX( VALUE, SUM ) 140 CONTINUE END IF ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN DO 150 I = 1, M WORK( I ) = ONE 150 CONTINUE DO 170 J = 1, N DO 160 I = 1, MIN( M, J-1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 160 CONTINUE 170 CONTINUE ELSE DO 180 I = 1, M WORK( I ) = ZERO 180 CONTINUE DO 200 J = 1, N DO 190 I = 1, MIN( M, J ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 190 CONTINUE 200 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN DO 210 I = 1, N WORK( I ) = ONE 210 CONTINUE DO 220 I = N + 1, M WORK( I ) = ZERO 220 CONTINUE DO 240 J = 1, N DO 230 I = J + 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 230 CONTINUE 240 CONTINUE ELSE DO 250 I = 1, M WORK( I ) = ZERO 250 CONTINUE DO 270 J = 1, N DO 260 I = J, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 260 CONTINUE 270 CONTINUE END IF END IF VALUE = ZERO DO 280 I = 1, M VALUE = MAX( VALUE, WORK( I ) ) 280 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN SCALE = ONE SUM = MIN( M, N ) DO 290 J = 2, N CALL ZLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM ) 290 CONTINUE ELSE SCALE = ZERO SUM = ONE DO 300 J = 1, N CALL ZLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM ) 300 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN SCALE = ONE SUM = MIN( M, N ) DO 310 J = 1, N CALL ZLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, $ SUM ) 310 CONTINUE ELSE SCALE = ZERO SUM = ONE DO 320 J = 1, N CALL ZLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) 320 CONTINUE END IF END IF VALUE = SCALE*SQRT( SUM ) END IF * ZLANTR = VALUE RETURN * * End of ZLANTR * END SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER LDA, M, N, OFFSET * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION VN1( * ), VN2( * ) COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZLAQP2 computes a QR factorization with column pivoting of * the block A(OFFSET+1:M,1:N). * The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * OFFSET (input) INTEGER * The number of rows of the matrix A that must be pivoted * but no factorized. OFFSET >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, the upper triangle of block A(OFFSET+1:M,1:N) is * the triangular factor obtained; the elements in block * A(OFFSET+1:M,1:N) below the diagonal, together with the * array TAU, represent the orthogonal matrix Q as a product of * elementary reflectors. Block A(1:OFFSET,1:N) has been * accordingly pivoted, but no factorized. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * JPVT (input/output) INTEGER array, dimension (N) * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted * to the front of A*P (a leading column); if JPVT(i) = 0, * the i-th column of A is a free column. * On exit, if JPVT(i) = k, then the i-th column of A*P * was the k-th column of A. * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors. * * VN1 (input/output) DOUBLE PRECISION array, dimension (N) * The vector with the partial column norms. * * VN2 (input/output) DOUBLE PRECISION array, dimension (N) * The vector with the exact column norms. * * WORK (workspace) COMPLEX*16 array, dimension (N) * * Further Details * =============== * * Based on contributions by * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain * X. Sun, Computer Science Dept., Duke University, USA * * Partial column norm updating strategy modified by * Z. Drmac and Z. Bujanovic, Dept. of Mathematics, * University of Zagreb, Croatia. * June 2006. * For more details see LAPACK Working Note 176. * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE COMPLEX*16 CONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MN, OFFPI, PVT DOUBLE PRECISION TEMP, TEMP2, TOL3Z COMPLEX*16 AII * .. * .. External Subroutines .. EXTERNAL ZLARF, ZLARFG, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DCONJG, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DZNRM2 EXTERNAL IDAMAX, DLAMCH, DZNRM2 * .. * .. Executable Statements .. * MN = MIN( M-OFFSET, N ) TOL3Z = SQRT(DLAMCH('Epsilon')) * * Compute factorization. * DO 20 I = 1, MN * OFFPI = OFFSET + I * * Determine ith pivot column and swap if necessary. * PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) * IF( PVT.NE.I ) THEN CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP VN1( PVT ) = VN1( I ) VN2( PVT ) = VN2( I ) END IF * * Generate elementary reflector H(i). * IF( OFFPI.LT.M ) THEN CALL ZLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, $ TAU( I ) ) ELSE CALL ZLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) END IF * IF( I.LT.N ) THEN * * Apply H(i)' to A(offset+i:m,i+1:n) from the left. * AII = A( OFFPI, I ) A( OFFPI, I ) = CONE CALL ZLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, $ DCONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA, $ WORK( 1 ) ) A( OFFPI, I ) = AII END IF * * Update partial column norms. * DO 10 J = I + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN IF( OFFPI.LT.M ) THEN VN1( J ) = DZNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) VN2( J ) = VN1( J ) ELSE VN1( J ) = ZERO VN2( J ) = ZERO END IF ELSE VN1( J ) = VN1( J )*SQRT( TEMP ) END IF END IF 10 CONTINUE * 20 CONTINUE * RETURN * * End of ZLAQP2 * END SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER KB, LDA, LDF, M, N, NB, OFFSET * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION VN1( * ), VN2( * ) COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) * .. * * Purpose * ======= * * ZLAQPS computes a step of QR factorization with column pivoting * of a complex M-by-N matrix A by using Blas-3. It tries to factorize * NB columns from A starting from the row OFFSET+1, and updates all * of the matrix with Blas-3 xGEMM. * * In some cases, due to catastrophic cancellations, it cannot * factorize NB columns. Hence, the actual number of factorized * columns is returned in KB. * * Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0 * * OFFSET (input) INTEGER * The number of rows of A that have been factorized in * previous steps. * * NB (input) INTEGER * The number of columns to factorize. * * KB (output) INTEGER * The number of columns actually factorized. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, block A(OFFSET+1:M,1:KB) is the triangular * factor obtained and block A(1:OFFSET,1:N) has been * accordingly pivoted, but no factorized. * The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has * been updated. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * JPVT (input/output) INTEGER array, dimension (N) * JPVT(I) = K <==> Column K of the full matrix A has been * permuted into position I in AP. * * TAU (output) COMPLEX*16 array, dimension (KB) * The scalar factors of the elementary reflectors. * * VN1 (input/output) DOUBLE PRECISION array, dimension (N) * The vector with the partial column norms. * * VN2 (input/output) DOUBLE PRECISION array, dimension (N) * The vector with the exact column norms. * * AUXV (input/output) COMPLEX*16 array, dimension (NB) * Auxiliar vector. * * F (input/output) COMPLEX*16 array, dimension (LDF,NB) * Matrix F' = L*Y'*A. * * LDF (input) INTEGER * The leading dimension of the array F. LDF >= max(1,N). * * Further Details * =============== * * Based on contributions by * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain * X. Sun, Computer Science Dept., Duke University, USA * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE COMPLEX*16 CZERO, CONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK DOUBLE PRECISION TEMP, TEMP2, TOL3Z COMPLEX*16 AKK * .. * .. External Subroutines .. EXTERNAL ZGEMM, ZGEMV, ZLARFG, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, MAX, MIN, NINT, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DZNRM2 EXTERNAL IDAMAX, DLAMCH, DZNRM2 * .. * .. Executable Statements .. * LASTRK = MIN( M, N+OFFSET ) LSTICC = 0 K = 0 TOL3Z = SQRT(DLAMCH('Epsilon')) * * Beginning of while loop. * 10 CONTINUE IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN K = K + 1 RK = OFFSET + K * * Determine ith pivot column and swap if necessary * PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) IF( PVT.NE.K ) THEN CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) CALL ZSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( K ) JPVT( K ) = ITEMP VN1( PVT ) = VN1( K ) VN2( PVT ) = VN2( K ) END IF * * Apply previous Householder reflectors to column K: * A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. * IF( K.GT.1 ) THEN DO 20 J = 1, K - 1 F( K, J ) = DCONJG( F( K, J ) ) 20 CONTINUE CALL ZGEMV( 'No transpose', M-RK+1, K-1, -CONE, A( RK, 1 ), $ LDA, F( K, 1 ), LDF, CONE, A( RK, K ), 1 ) DO 30 J = 1, K - 1 F( K, J ) = DCONJG( F( K, J ) ) 30 CONTINUE END IF * * Generate elementary reflector H(k). * IF( RK.LT.M ) THEN CALL ZLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) ELSE CALL ZLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) END IF * AKK = A( RK, K ) A( RK, K ) = CONE * * Compute Kth column of F: * * Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). * IF( K.LT.N ) THEN CALL ZGEMV( 'Conjugate transpose', M-RK+1, N-K, TAU( K ), $ A( RK, K+1 ), LDA, A( RK, K ), 1, CZERO, $ F( K+1, K ), 1 ) END IF * * Padding F(1:K,K) with zeros. * DO 40 J = 1, K F( J, K ) = CZERO 40 CONTINUE * * Incremental updating of F: * F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' * *A(RK:M,K). * IF( K.GT.1 ) THEN CALL ZGEMV( 'Conjugate transpose', M-RK+1, K-1, -TAU( K ), $ A( RK, 1 ), LDA, A( RK, K ), 1, CZERO, $ AUXV( 1 ), 1 ) * CALL ZGEMV( 'No transpose', N, K-1, CONE, F( 1, 1 ), LDF, $ AUXV( 1 ), 1, CONE, F( 1, K ), 1 ) END IF * * Update the current row of A: * A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. * IF( K.LT.N ) THEN CALL ZGEMM( 'No transpose', 'Conjugate transpose', 1, N-K, $ K, -CONE, A( RK, 1 ), LDA, F( K+1, 1 ), LDF, $ CONE, A( RK, K+1 ), LDA ) END IF * * Update partial column norms. * IF( RK.LT.LASTRK ) THEN DO 50 J = K + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN VN2( J ) = DBLE( LSTICC ) LSTICC = J ELSE VN1( J ) = VN1( J )*SQRT( TEMP ) END IF END IF 50 CONTINUE END IF * A( RK, K ) = AKK * * End of while loop. * GO TO 10 END IF KB = K RK = OFFSET + KB * * Apply the block reflector to the rest of the matrix: * A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - * A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. * IF( KB.LT.MIN( N, M-OFFSET ) ) THEN CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-RK, N-KB, $ KB, -CONE, A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, $ CONE, A( RK+1, KB+1 ), LDA ) END IF * * Recomputation of difficult columns. * 60 CONTINUE IF( LSTICC.GT.0 ) THEN ITEMP = NINT( VN2( LSTICC ) ) VN1( LSTICC ) = DZNRM2( M-RK, A( RK+1, LSTICC ), 1 ) * * NOTE: The computation of VN1( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * VN2( LSTICC ) = VN1( LSTICC ) LSTICC = ITEMP GO TO 60 END IF * RETURN * * End of ZLAQPS * END SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * ZLAQR0 computes the eigenvalues of a Hessenberg matrix H * and, optionally, the matrices T and Z from the Schur decomposition * H = Z T Z**H, where T is an upper triangular matrix (the * Schur form), and Z is the unitary matrix of Schur vectors. * * Optionally Z may be postmultiplied into an input unitary * matrix Q so that this routine can give the Schur factorization * of a matrix A which has been reduced to the Hessenberg form H * by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. * * Arguments * ========= * * WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * * WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * * N (input) INTEGER * The order of the matrix H. N .GE. 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that H is already upper triangular in rows * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a * previous call to ZGEBAL, and then passed to ZGEHRD when the * matrix output by ZGEBAL is reduced to Hessenberg form. * Otherwise, ILO and IHI should be set to 1 and N, * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. * If N = 0, then ILO = 1 and IHI = 0. * * H (input/output) COMPLEX*16 array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. * On exit, if INFO = 0 and WANTT is .TRUE., then H * contains the upper triangular matrix T from the Schur * decomposition (the Schur form). If INFO = 0 and WANT is * .FALSE., then the contents of H are unspecified on exit. * (The output value of H when INFO.GT.0 is given under the * description of INFO below.) * * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. * * LDH (input) INTEGER * The leading dimension of the array H. LDH .GE. max(1,N). * * W (output) COMPLEX*16 array, dimension (N) * The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored * in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are * stored in the same order as on the diagonal of the Schur * form returned in H, with W(i) = H(i,i). * * Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) * If WANTZ is .FALSE., then Z is not referenced. * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the * orthogonal Schur factor of H(ILO:IHI,ILO:IHI). * (The output value of Z when INFO.GT.0 is given under * the description of INFO below.) * * LDZ (input) INTEGER * The leading dimension of the array Z. if WANTZ is .TRUE. * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. * * WORK (workspace/output) COMPLEX*16 array, dimension LWORK * On exit, if LWORK = -1, WORK(1) returns an estimate of * the optimal value for LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK .GE. max(1,N) * is sufficient, but LWORK typically as large as 6*N may * be required for optimal performance. A workspace query * to determine the optimal workspace size is recommended. * * If LWORK = -1, then ZLAQR0 does a workspace query. * In this case, ZLAQR0 checks the input parameters and * estimates the optimal workspace size for the given * values of N, ILO and IHI. The estimate is returned * in WORK(1). No error message related to LWORK is * issued by XERBLA. Neither H nor Z are accessed. * * * INFO (output) INTEGER * = 0: successful exit * .GT. 0: if INFO = i, ZLAQR0 failed to compute all of * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR * and WI contain those eigenvalues which have been * successfully computed. (Failures are rare.) * * If INFO .GT. 0 and WANT is .FALSE., then on exit, * the remaining unconverged eigenvalues are the eigen- * values of the upper Hessenberg matrix rows and * columns ILO through INFO of the final, output * value of H. * * If INFO .GT. 0 and WANTT is .TRUE., then on exit * * (*) (initial value of H)*U = U*(final value of H) * * where U is a unitary matrix. The final * value of H is upper Hessenberg and triangular in * rows and columns INFO+1 through IHI. * * If INFO .GT. 0 and WANTZ is .TRUE., then on exit * * (final value of Z(ILO:IHI,ILOZ:IHIZ) * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U * * where U is the unitary matrix in (*) (regard- * less of the value of WANTT.) * * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not * accessed. * * ================================================================ * Based on contributions by * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * * ================================================================ * References: * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 * Performance, SIAM Journal of Matrix Analysis, volume 23, pages * 929--947, 2002. * * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR * Algorithm Part II: Aggressive Early Deflation, SIAM Journal * of Matrix Analysis, volume 23, pages 948--973, 2002. * * ================================================================ * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . ZLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== * * ==== Exceptional deflation windows: try to cure rare * . slow convergence by increasing the size of the * . deflation window after KEXNW iterations. ===== * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. * . The constants WILK1 and WILK2 are used to form the * . exceptional shifts. ==== * INTEGER NTINY PARAMETER ( NTINY = 11 ) INTEGER KEXNW, KEXSH PARAMETER ( KEXNW = 5, KEXSH = 6 ) DOUBLE PRECISION WILK1 PARAMETER ( WILK1 = 0.75d0 ) COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 DOUBLE PRECISION S INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, $ NSR, NVE, NW, NWMAX, NWR LOGICAL NWINC, SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Local Arrays .. COMPLEX*16 ZDUM( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, $ SQRT * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. INFO = 0 * * ==== Quick return for N = 0: nothing to do. ==== * IF( N.EQ.0 ) THEN WORK( 1 ) = ONE RETURN END IF * * ==== Set up job flags for ILAENV. ==== * IF( WANTT ) THEN JBCMPZ( 1: 1 ) = 'S' ELSE JBCMPZ( 1: 1 ) = 'E' END IF IF( WANTZ ) THEN JBCMPZ( 2: 2 ) = 'V' ELSE JBCMPZ( 2: 2 ) = 'N' END IF * * ==== Tiny matrices must use ZLAHQR. ==== * IF( N.LE.NTINY ) THEN * * ==== Estimate optimal workspace. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) ELSE * * ==== Use small bulge multi-shift QR with aggressive early * . deflation on larger-than-tiny matrices. ==== * * ==== Hope for the best. ==== * INFO = 0 * * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. * . (In fact, there is enough subdiagonal space for * . NWR.GE.3.) ==== * NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) NW = NWR * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at * . enough subdiagonal workspace for NSR to be even * . and greater than or equal to two as required. ==== * NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) * * ==== Estimate optimal workspace ==== * * ==== Workspace query call to ZLAQR3 ==== * CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, $ LDH, WORK, -1 ) * * ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ==== * LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DCMPLX( LWKOPT, 0 ) RETURN END IF * * ==== ZLAHQR/ZLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== Nibble crossover point ==== * NIBBLE = ILAENV( 14, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NIBBLE = MAX( 0, NIBBLE ) * * ==== Accumulate reflections during ttswp? Use block * . 2-by-2 structure during matrix-matrix multiply? ==== * KACC22 = ILAENV( 16, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) KACC22 = MAX( 0, KACC22 ) KACC22 = MIN( 2, KACC22 ) * * ==== NWMAX = the largest possible deflation window for * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== * NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) NSMAX = NSMAX - MOD( NSMAX, 2 ) * * ==== NDFL: an iteration count restarted at deflation. ==== * NDFL = 1 * * ==== ITMAX = iteration limit ==== * ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) * * ==== Last row and column in the active block ==== * KBOT = IHI * * ==== Main Loop ==== * DO 70 IT = 1, ITMAX * * ==== Done when KBOT falls below ILO ==== * IF( KBOT.LT.ILO ) $ GO TO 80 * * ==== Locate active block ==== * DO 10 K = KBOT, ILO + 1, -1 IF( H( K, K-1 ).EQ.ZERO ) $ GO TO 20 10 CONTINUE K = ILO 20 CONTINUE KTOP = K * * ==== Select deflation window size ==== * NH = KBOT - KTOP + 1 IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN * * ==== Typical deflation window. If possible and * . advisable, nibble the entire active block. * . If not, use size NWR or NWR+1 depending upon * . which has the smaller corresponding subdiagonal * . entry (a heuristic). ==== * NWINC = .TRUE. IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN NW = NH ELSE NW = MIN( NWR, NH, NWMAX ) IF( NW.LT.NWMAX ) THEN IF( NW.GE.NH-1 ) THEN NW = NH ELSE KWTOP = KBOT - NW + 1 IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF END IF ELSE * * ==== Exceptional deflation window. If there have * . been no deflations in KEXNW or more iterations, * . then vary the deflation window size. At first, * . because, larger windows are, in general, more * . powerful than smaller ones, rapidly increase the * . window up to the maximum reasonable and possible. * . Then maybe try a slightly smaller window. ==== * IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN NW = MIN( NWMAX, NH, 2*NW ) ELSE NWINC = .FALSE. IF( NW.EQ.NH .AND. NH.GT.2 ) $ NW = NH - 1 END IF END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into * . - an nw-by-nw work array V in the lower * . left-hand-corner, * . - an NW-by-at-least-NW-but-more-is-better * . (NW-by-NHO) horizontal work array along * . the bottom edge, * . - an at-least-NW-but-more-is-better (NHV-by-NW) * . vertical work array along the left-hand-edge. * . ==== * KV = N - NW + 1 KT = NW + 1 NHO = ( N-NW-1 ) - KT + 1 KWV = NW + 2 NVE = ( N-NW ) - KWV + 1 * * ==== Aggressive early deflation ==== * CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, $ LWORK ) * * ==== Adjust KBOT accounting for new deflations. ==== * KBOT = KBOT - LD * * ==== KS points to the shifts. ==== * KS = KBOT - LS + 1 * * ==== Skip an expensive QR sweep if there is a (partly * . heuristic) reason to expect that many eigenvalues * . will deflate without it. Here, the QR sweep is * . skipped if many eigenvalues have just been deflated * . or if the remaining active block is small. * IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN * * ==== NS = nominal number of simultaneous shifts. * . This may be lowered (slightly) if ZLAQR3 * . did not provide that many shifts. ==== * NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) NS = NS - MOD( NS, 2 ) * * ==== If there have been no deflations * . in a multiple of KEXSH iterations, * . then try exceptional shifts. * . Otherwise use shifts provided by * . ZLAQR3 above or from the eigenvalues * . of a trailing principal submatrix. ==== * IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN KS = KBOT - NS + 1 DO 30 I = KBOT, KS + 1, -2 W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) W( I-1 ) = W( I ) 30 CONTINUE ELSE * * ==== Got NS/2 or fewer shifts? Use ZLAQR4 or * . ZLAHQR on a trailing principal submatrix to * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, * . there is enough space below the subdiagonal * . to fit an NS-by-NS scratch array.) ==== * IF( KBOT-KS+1.LE.NS / 2 ) THEN KS = KBOT - NS + 1 KT = N - NS + 1 CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, $ H( KT, 1 ), LDH ) IF( NS.GT.NMIN ) THEN CALL ZLAQR4( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, W( KS ), 1, 1, $ ZDUM, 1, WORK, LWORK, INF ) ELSE CALL ZLAHQR( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, W( KS ), 1, 1, $ ZDUM, 1, INF ) END IF KS = KS + INF * * ==== In case of a rare QR failure use * . eigenvalues of the trailing 2-by-2 * . principal submatrix. Scale to avoid * . overflows, underflows and subnormals. * . (The scale factor S can not be zero, * . because H(KBOT,KBOT-1) is nonzero.) ==== * IF( KS.GE.KBOT ) THEN S = CABS1( H( KBOT-1, KBOT-1 ) ) + $ CABS1( H( KBOT, KBOT-1 ) ) + $ CABS1( H( KBOT-1, KBOT ) ) + $ CABS1( H( KBOT, KBOT ) ) AA = H( KBOT-1, KBOT-1 ) / S CC = H( KBOT, KBOT-1 ) / S BB = H( KBOT-1, KBOT ) / S DD = H( KBOT, KBOT ) / S TR2 = ( AA+DD ) / TWO DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC RTDISC = SQRT( -DET ) W( KBOT-1 ) = ( TR2+RTDISC )*S W( KBOT ) = ( TR2-RTDISC )*S * KS = KBOT - 1 END IF END IF * IF( KBOT-KS+1.GT.NS ) THEN * * ==== Sort the shifts (Helps a little) ==== * SORTED = .false. DO 50 K = KBOT, KS + 1, -1 IF( SORTED ) $ GO TO 60 SORTED = .true. DO 40 I = KS, K - 1 IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) $ THEN SORTED = .false. SWAP = W( I ) W( I ) = W( I+1 ) W( I+1 ) = SWAP END IF 40 CONTINUE 50 CONTINUE 60 CONTINUE END IF END IF * * ==== If there are only two shifts, then use * . only one. ==== * IF( KBOT-KS+1.EQ.2 ) THEN IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN W( KBOT-1 ) = W( KBOT ) ELSE W( KBOT ) = W( KBOT-1 ) END IF END IF * * ==== Use up to NS of the the smallest magnatiude * . shifts. If there aren't NS shifts available, * . then use them all, possibly dropping one to * . make the number of shifts even. ==== * NS = MIN( NS, KBOT-KS+1 ) NS = NS - MOD( NS, 2 ) KS = KBOT - NS + 1 * * ==== Small-bulge multi-shift QR sweep: * . split workspace under the subdiagonal into * . - a KDU-by-KDU work array U in the lower * . left-hand-corner, * . - a KDU-by-at-least-KDU-but-more-is-better * . (KDU-by-NHo) horizontal work array WH along * . the bottom edge, * . - and an at-least-KDU-but-more-is-better-by-KDU * . (NVE-by-KDU) vertical work WV arrow along * . the left-hand-edge. ==== * KDU = 3*NS - 3 KU = N - KDU + 1 KWH = KDU + 1 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 KWV = KDU + 4 NVE = N - KDU - KWV + 1 * * ==== Small-bulge multi-shift QR sweep ==== * CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, $ NHO, H( KU, KWH ), LDH ) END IF * * ==== Note progress (or the lack of it). ==== * IF( LD.GT.0 ) THEN NDFL = 1 ELSE NDFL = NDFL + 1 END IF * * ==== End of main loop ==== 70 CONTINUE * * ==== Iteration limit exceeded. Set INFO to show where * . the problem occurred and exit. ==== * INFO = KBOT 80 CONTINUE END IF * * ==== Return the optimal value of LWORK. ==== * WORK( 1 ) = DCMPLX( LWKOPT, 0 ) * * ==== End of ZLAQR0 ==== * END SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. COMPLEX*16 S1, S2 INTEGER LDH, N * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), V( * ) * .. * * Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a * scalar multiple of the first column of the product * * (*) K = (H - s1*I)*(H - s2*I) * * scaling to avoid overflows and most underflows. * * This is useful for starting double implicit shift bulges * in the QR algorithm. * * * N (input) integer * Order of the matrix H. N must be either 2 or 3. * * H (input) COMPLEX*16 array of dimension (LDH,N) * The 2-by-2 or 3-by-3 matrix H in (*). * * LDH (input) integer * The leading dimension of H as declared in * the calling procedure. LDH.GE.N * * S1 (input) COMPLEX*16 * S2 S1 and S2 are the shifts defining K in (*) above. * * V (output) COMPLEX*16 array of dimension N * A scalar multiple of the first column of the * matrix K in (*). * * ================================================================ * Based on contributions by * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * * ================================================================ * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ) ) DOUBLE PRECISION RZERO PARAMETER ( RZERO = 0.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 CDUM DOUBLE PRECISION H21S, H31S, S * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. IF( N.EQ.2 ) THEN S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) IF( S.EQ.RZERO ) THEN V( 1 ) = ZERO V( 2 ) = ZERO ELSE H21S = H( 2, 1 ) / S V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )* $ ( ( H( 1, 1 )-S2 ) / S ) V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) END IF ELSE S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + $ CABS1( H( 3, 1 ) ) IF( S.EQ.ZERO ) THEN V( 1 ) = ZERO V( 2 ) = ZERO V( 3 ) = ZERO ELSE H21S = H( 2, 1 ) / S H31S = H( 3, 1 ) / S V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) + $ H( 1, 2 )*H21S + H( 1, 3 )*H31S V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 ) END IF END IF END SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, $ NV, WV, LDWV, WORK, LWORK ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, $ LDZ, LWORK, N, ND, NH, NS, NV, NW LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * This subroutine is identical to ZLAQR3 except that it avoids * recursion by calling ZLAHQR instead of ZLAQR4. * * * ****************************************************************** * Aggressive early deflation: * * This subroutine accepts as input an upper Hessenberg matrix * H and performs an unitary similarity transformation * designed to detect and deflate fully converged eigenvalues from * a trailing principal submatrix. On output H has been over- * written by a new Hessenberg matrix that is a perturbation of * an unitary similarity transformation of H. It is to be * hoped that the final version of H has many zero subdiagonal * entries. * * ****************************************************************** * WANTT (input) LOGICAL * If .TRUE., then the Hessenberg matrix H is fully updated * so that the triangular Schur factor may be * computed (in cooperation with the calling subroutine). * If .FALSE., then only enough of H is updated to preserve * the eigenvalues. * * WANTZ (input) LOGICAL * If .TRUE., then the unitary matrix Z is updated so * so that the unitary Schur factor may be computed * (in cooperation with the calling subroutine). * If .FALSE., then Z is not referenced. * * N (input) INTEGER * The order of the matrix H and (if WANTZ is .TRUE.) the * order of the unitary matrix Z. * * KTOP (input) INTEGER * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. * KBOT and KTOP together determine an isolated block * along the diagonal of the Hessenberg matrix. * * KBOT (input) INTEGER * It is assumed without a check that either * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together * determine an isolated block along the diagonal of the * Hessenberg matrix. * * NW (input) INTEGER * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). * * H (input/output) COMPLEX*16 array, dimension (LDH,N) * On input the initial N-by-N section of H stores the * Hessenberg matrix undergoing aggressive early deflation. * On output H has been transformed by a unitary * similarity transformation, perturbed, and the returned * to Hessenberg form that (it is to be hoped) has some * zero subdiagonal entries. * * LDH (input) integer * Leading dimension of H just as declared in the calling * subroutine. N .LE. LDH * * ILOZ (input) INTEGER * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. * * Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) * IF WANTZ is .TRUE., then on output, the unitary * similarity transformation mentioned above has been * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. * If WANTZ is .FALSE., then Z is unreferenced. * * LDZ (input) integer * The leading dimension of Z just as declared in the * calling subroutine. 1 .LE. LDZ. * * NS (output) integer * The number of unconverged (ie approximate) eigenvalues * returned in SR and SI that may be used as shifts by the * calling subroutine. * * ND (output) integer * The number of converged eigenvalues uncovered by this * subroutine. * * SH (output) COMPLEX*16 array, dimension KBOT * On output, approximate eigenvalues that may * be used for shifts are stored in SH(KBOT-ND-NS+1) * through SR(KBOT-ND). Converged eigenvalues are * stored in SH(KBOT-ND+1) through SH(KBOT). * * V (workspace) COMPLEX*16 array, dimension (LDV,NW) * An NW-by-NW work array. * * LDV (input) integer scalar * The leading dimension of V just as declared in the * calling subroutine. NW .LE. LDV * * NH (input) integer scalar * The number of columns of T. NH.GE.NW. * * T (workspace) COMPLEX*16 array, dimension (LDT,NW) * * LDT (input) integer * The leading dimension of T just as declared in the * calling subroutine. NW .LE. LDT * * NV (input) integer * The number of rows of work array WV available for * workspace. NV.GE.NW. * * WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) * * LDWV (input) integer * The leading dimension of W just as declared in the * calling subroutine. NW .LE. LDV * * WORK (workspace) COMPLEX*16 array, dimension LWORK. * On exit, WORK(1) is set to an estimate of the optimal value * of LWORK for the given values of N, NW, KTOP and KBOT. * * LWORK (input) integer * The dimension of the work array WORK. LWORK = 2*NW * suffices, but greater efficiency may result from larger * values of LWORK. * * If LWORK = -1, then a workspace query is assumed; ZLAQR2 * only estimates the optimal workspace size for the given * values of N, NW, KTOP and KBOT. The estimate is returned * in WORK(1). No error message related to LWORK is issued * by XERBLA. Neither H nor Z are accessed. * * ================================================================ * Based on contributions by * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * * ================================================================== * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION RZERO, RONE PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 BETA, CDUM, S, TAU DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, $ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * * ==== Estimate optimal workspace. ==== * JW = MIN( NW, KBOT-KTOP+1 ) IF( JW.LE.2 ) THEN LWKOPT = 1 ELSE * * ==== Workspace query call to ZGEHRD ==== * CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * * ==== Workspace query call to ZUNGHR ==== * CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== * LWKOPT = JW + MAX( LWK1, LWK2 ) END IF * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DCMPLX( LWKOPT, 0 ) RETURN END IF * * ==== Nothing to do ... * ... for an empty active block ... ==== NS = 0 ND = 0 IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== IF( NW.LT.1 ) $ RETURN * * ==== Machine constants ==== * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( N ) / ULP ) * * ==== Setup deflation window ==== * JW = MIN( NW, KBOT-KTOP+1 ) KWTOP = KBOT - JW + 1 IF( KWTOP.EQ.KTOP ) THEN S = ZERO ELSE S = H( KWTOP, KWTOP-1 ) END IF * IF( KBOT.EQ.KWTOP ) THEN * * ==== 1-by-1 deflation window: not much to do ==== * SH( KWTOP ) = H( KWTOP, KWTOP ) NS = 1 ND = 0 IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, $ KWTOP ) ) ) ) THEN NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF RETURN END IF * * ==== Convert to spike-triangular form. (In case of a * . rare QR failure, this routine continues to do * . aggressive early deflation using that part of * . the deflation window that converged using INFQR * . here and there to keep track.) ==== * CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) * CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, $ JW, V, LDV, INFQR ) * * ==== Deflation detection loop ==== * NS = JW ILST = INFQR + 1 DO 10 KNT = INFQR + 1, JW * * ==== Small spike tip deflation test ==== * FOO = CABS1( T( NS, NS ) ) IF( FOO.EQ.RZERO ) $ FOO = CABS1( S ) IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) $ THEN * * ==== One more converged eigenvalue ==== * NS = NS - 1 ELSE * * ==== One undflatable eigenvalue. Move it up out of the * . way. (ZTREXC can not fail in this case.) ==== * IFST = NS CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) ILST = ILST + 1 END IF 10 CONTINUE * * ==== Return to Hessenberg form ==== * IF( NS.EQ.0 ) $ S = ZERO * IF( NS.LT.JW ) THEN * * ==== sorting the diagonal of T improves accuracy for * . graded matrices. ==== * DO 30 I = INFQR + 1, NS IFST = I DO 20 J = I + 1, NS IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) $ IFST = J 20 CONTINUE ILST = I IF( IFST.NE.ILST ) $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) 30 CONTINUE END IF * * ==== Restore shift/eigenvalue array from T ==== * DO 40 I = INFQR + 1, JW SH( KWTOP+I-1 ) = T( I, I ) 40 CONTINUE * * IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN IF( NS.GT.1 .AND. S.NE.ZERO ) THEN * * ==== Reflect spike back into lower triangle ==== * CALL ZCOPY( NS, V, LDV, WORK, 1 ) DO 50 I = 1, NS WORK( I ) = DCONJG( WORK( I ) ) 50 CONTINUE BETA = WORK( 1 ) CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) * CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, $ WORK( JW+1 ) ) CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, $ WORK( JW+1 ) ) * CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) END IF * * ==== Copy updated reduced window into place ==== * IF( KWTOP.GT.1 ) $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update * . H and Z, if requested. (A modified version * . of ZUNGHR that accumulates block Householder * . transformations into V directly might be * . marginally more efficient than the following.) ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) THEN CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, $ WV, LDWV ) CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) END IF * * ==== Update vertical slab in H ==== * IF( WANTT ) THEN LTOP = 1 ELSE LTOP = KTOP END IF DO 60 KROW = LTOP, KWTOP - 1, NV KLN = MIN( NV, KWTOP-KROW ) CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 60 CONTINUE * * ==== Update horizontal slab in H ==== * IF( WANTT ) THEN DO 70 KCOL = KBOT + 1, N, NH KLN = MIN( NH, N-KCOL+1 ) CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), $ LDH ) 70 CONTINUE END IF * * ==== Update vertical slab in Z ==== * IF( WANTZ ) THEN DO 80 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) 80 CONTINUE END IF END IF * * ==== Return the number of deflations ... ==== * ND = JW - NS * * ==== ... and the number of shifts. (Subtracting * . INFQR from the spike length takes care * . of the case of a rare QR failure while * . calculating eigenvalues of the deflation * . window.) ==== * NS = NS - INFQR * * ==== Return optimal workspace. ==== * WORK( 1 ) = DCMPLX( LWKOPT, 0 ) * * ==== End of ZLAQR2 ==== * END SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, $ NV, WV, LDWV, WORK, LWORK ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, $ LDZ, LWORK, N, ND, NH, NS, NV, NW LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * ****************************************************************** * Aggressive early deflation: * * This subroutine accepts as input an upper Hessenberg matrix * H and performs an unitary similarity transformation * designed to detect and deflate fully converged eigenvalues from * a trailing principal submatrix. On output H has been over- * written by a new Hessenberg matrix that is a perturbation of * an unitary similarity transformation of H. It is to be * hoped that the final version of H has many zero subdiagonal * entries. * * ****************************************************************** * WANTT (input) LOGICAL * If .TRUE., then the Hessenberg matrix H is fully updated * so that the triangular Schur factor may be * computed (in cooperation with the calling subroutine). * If .FALSE., then only enough of H is updated to preserve * the eigenvalues. * * WANTZ (input) LOGICAL * If .TRUE., then the unitary matrix Z is updated so * so that the unitary Schur factor may be computed * (in cooperation with the calling subroutine). * If .FALSE., then Z is not referenced. * * N (input) INTEGER * The order of the matrix H and (if WANTZ is .TRUE.) the * order of the unitary matrix Z. * * KTOP (input) INTEGER * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. * KBOT and KTOP together determine an isolated block * along the diagonal of the Hessenberg matrix. * * KBOT (input) INTEGER * It is assumed without a check that either * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together * determine an isolated block along the diagonal of the * Hessenberg matrix. * * NW (input) INTEGER * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). * * H (input/output) COMPLEX*16 array, dimension (LDH,N) * On input the initial N-by-N section of H stores the * Hessenberg matrix undergoing aggressive early deflation. * On output H has been transformed by a unitary * similarity transformation, perturbed, and the returned * to Hessenberg form that (it is to be hoped) has some * zero subdiagonal entries. * * LDH (input) integer * Leading dimension of H just as declared in the calling * subroutine. N .LE. LDH * * ILOZ (input) INTEGER * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. * * Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) * IF WANTZ is .TRUE., then on output, the unitary * similarity transformation mentioned above has been * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. * If WANTZ is .FALSE., then Z is unreferenced. * * LDZ (input) integer * The leading dimension of Z just as declared in the * calling subroutine. 1 .LE. LDZ. * * NS (output) integer * The number of unconverged (ie approximate) eigenvalues * returned in SR and SI that may be used as shifts by the * calling subroutine. * * ND (output) integer * The number of converged eigenvalues uncovered by this * subroutine. * * SH (output) COMPLEX*16 array, dimension KBOT * On output, approximate eigenvalues that may * be used for shifts are stored in SH(KBOT-ND-NS+1) * through SR(KBOT-ND). Converged eigenvalues are * stored in SH(KBOT-ND+1) through SH(KBOT). * * V (workspace) COMPLEX*16 array, dimension (LDV,NW) * An NW-by-NW work array. * * LDV (input) integer scalar * The leading dimension of V just as declared in the * calling subroutine. NW .LE. LDV * * NH (input) integer scalar * The number of columns of T. NH.GE.NW. * * T (workspace) COMPLEX*16 array, dimension (LDT,NW) * * LDT (input) integer * The leading dimension of T just as declared in the * calling subroutine. NW .LE. LDT * * NV (input) integer * The number of rows of work array WV available for * workspace. NV.GE.NW. * * WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) * * LDWV (input) integer * The leading dimension of W just as declared in the * calling subroutine. NW .LE. LDV * * WORK (workspace) COMPLEX*16 array, dimension LWORK. * On exit, WORK(1) is set to an estimate of the optimal value * of LWORK for the given values of N, NW, KTOP and KBOT. * * LWORK (input) integer * The dimension of the work array WORK. LWORK = 2*NW * suffices, but greater efficiency may result from larger * values of LWORK. * * If LWORK = -1, then a workspace query is assumed; ZLAQR3 * only estimates the optimal workspace size for the given * values of N, NW, KTOP and KBOT. The estimate is returned * in WORK(1). No error message related to LWORK is issued * by XERBLA. Neither H nor Z are accessed. * * ================================================================ * Based on contributions by * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * * ================================================================== * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION RZERO, RONE PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 BETA, CDUM, S, TAU DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, $ LWKOPT, NMIN * .. * .. External Functions .. DOUBLE PRECISION DLAMCH INTEGER ILAENV EXTERNAL DLAMCH, ILAENV * .. * .. External Subroutines .. EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, $ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * * ==== Estimate optimal workspace. ==== * JW = MIN( NW, KBOT-KTOP+1 ) IF( JW.LE.2 ) THEN LWKOPT = 1 ELSE * * ==== Workspace query call to ZGEHRD ==== * CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * * ==== Workspace query call to ZUNGHR ==== * CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Workspace query call to ZLAQR4 ==== * CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, $ LDV, WORK, -1, INFQR ) LWK3 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== * LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) END IF * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DCMPLX( LWKOPT, 0 ) RETURN END IF * * ==== Nothing to do ... * ... for an empty active block ... ==== NS = 0 ND = 0 IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== IF( NW.LT.1 ) $ RETURN * * ==== Machine constants ==== * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( N ) / ULP ) * * ==== Setup deflation window ==== * JW = MIN( NW, KBOT-KTOP+1 ) KWTOP = KBOT - JW + 1 IF( KWTOP.EQ.KTOP ) THEN S = ZERO ELSE S = H( KWTOP, KWTOP-1 ) END IF * IF( KBOT.EQ.KWTOP ) THEN * * ==== 1-by-1 deflation window: not much to do ==== * SH( KWTOP ) = H( KWTOP, KWTOP ) NS = 1 ND = 0 IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, $ KWTOP ) ) ) ) THEN NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF RETURN END IF * * ==== Convert to spike-triangular form. (In case of a * . rare QR failure, this routine continues to do * . aggressive early deflation using that part of * . the deflation window that converged using INFQR * . here and there to keep track.) ==== * CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) * CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK ) IF( JW.GT.NMIN ) THEN CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, $ JW, V, LDV, WORK, LWORK, INFQR ) ELSE CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, $ JW, V, LDV, INFQR ) END IF * * ==== Deflation detection loop ==== * NS = JW ILST = INFQR + 1 DO 10 KNT = INFQR + 1, JW * * ==== Small spike tip deflation test ==== * FOO = CABS1( T( NS, NS ) ) IF( FOO.EQ.RZERO ) $ FOO = CABS1( S ) IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) $ THEN * * ==== One more converged eigenvalue ==== * NS = NS - 1 ELSE * * ==== One undflatable eigenvalue. Move it up out of the * . way. (ZTREXC can not fail in this case.) ==== * IFST = NS CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) ILST = ILST + 1 END IF 10 CONTINUE * * ==== Return to Hessenberg form ==== * IF( NS.EQ.0 ) $ S = ZERO * IF( NS.LT.JW ) THEN * * ==== sorting the diagonal of T improves accuracy for * . graded matrices. ==== * DO 30 I = INFQR + 1, NS IFST = I DO 20 J = I + 1, NS IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) $ IFST = J 20 CONTINUE ILST = I IF( IFST.NE.ILST ) $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) 30 CONTINUE END IF * * ==== Restore shift/eigenvalue array from T ==== * DO 40 I = INFQR + 1, JW SH( KWTOP+I-1 ) = T( I, I ) 40 CONTINUE * * IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN IF( NS.GT.1 .AND. S.NE.ZERO ) THEN * * ==== Reflect spike back into lower triangle ==== * CALL ZCOPY( NS, V, LDV, WORK, 1 ) DO 50 I = 1, NS WORK( I ) = DCONJG( WORK( I ) ) 50 CONTINUE BETA = WORK( 1 ) CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) * CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, $ WORK( JW+1 ) ) CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, $ WORK( JW+1 ) ) * CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) END IF * * ==== Copy updated reduced window into place ==== * IF( KWTOP.GT.1 ) $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update * . H and Z, if requested. (A modified version * . of ZUNGHR that accumulates block Householder * . transformations into V directly might be * . marginally more efficient than the following.) ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) THEN CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, $ WV, LDWV ) CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) END IF * * ==== Update vertical slab in H ==== * IF( WANTT ) THEN LTOP = 1 ELSE LTOP = KTOP END IF DO 60 KROW = LTOP, KWTOP - 1, NV KLN = MIN( NV, KWTOP-KROW ) CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 60 CONTINUE * * ==== Update horizontal slab in H ==== * IF( WANTT ) THEN DO 70 KCOL = KBOT + 1, N, NH KLN = MIN( NH, N-KCOL+1 ) CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), $ LDH ) 70 CONTINUE END IF * * ==== Update vertical slab in Z ==== * IF( WANTZ ) THEN DO 80 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) 80 CONTINUE END IF END IF * * ==== Return the number of deflations ... ==== * ND = JW - NS * * ==== ... and the number of shifts. (Subtracting * . INFQR from the spike length takes care * . of the case of a rare QR failure while * . calculating eigenvalues of the deflation * . window.) ==== * NS = NS - INFQR * * ==== Return optimal workspace. ==== * WORK( 1 ) = DCMPLX( LWKOPT, 0 ) * * ==== End of ZLAQR3 ==== * END SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * This subroutine implements one level of recursion for ZLAQR0. * It is a complete implementation of the small bulge multi-shift * QR algorithm. It may be called by ZLAQR0 and, for large enough * deflation window size, it may be called by ZLAQR3. This * subroutine is identical to ZLAQR0 except that it calls ZLAQR2 * instead of ZLAQR3. * * Purpose * ======= * * ZLAQR4 computes the eigenvalues of a Hessenberg matrix H * and, optionally, the matrices T and Z from the Schur decomposition * H = Z T Z**H, where T is an upper triangular matrix (the * Schur form), and Z is the unitary matrix of Schur vectors. * * Optionally Z may be postmultiplied into an input unitary * matrix Q so that this routine can give the Schur factorization * of a matrix A which has been reduced to the Hessenberg form H * by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. * * Arguments * ========= * * WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * * WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * * N (input) INTEGER * The order of the matrix H. N .GE. 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that H is already upper triangular in rows * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a * previous call to ZGEBAL, and then passed to ZGEHRD when the * matrix output by ZGEBAL is reduced to Hessenberg form. * Otherwise, ILO and IHI should be set to 1 and N, * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. * If N = 0, then ILO = 1 and IHI = 0. * * H (input/output) COMPLEX*16 array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. * On exit, if INFO = 0 and WANTT is .TRUE., then H * contains the upper triangular matrix T from the Schur * decomposition (the Schur form). If INFO = 0 and WANT is * .FALSE., then the contents of H are unspecified on exit. * (The output value of H when INFO.GT.0 is given under the * description of INFO below.) * * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. * * LDH (input) INTEGER * The leading dimension of the array H. LDH .GE. max(1,N). * * W (output) COMPLEX*16 array, dimension (N) * The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored * in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are * stored in the same order as on the diagonal of the Schur * form returned in H, with W(i) = H(i,i). * * Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) * If WANTZ is .FALSE., then Z is not referenced. * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the * orthogonal Schur factor of H(ILO:IHI,ILO:IHI). * (The output value of Z when INFO.GT.0 is given under * the description of INFO below.) * * LDZ (input) INTEGER * The leading dimension of the array Z. if WANTZ is .TRUE. * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. * * WORK (workspace/output) COMPLEX*16 array, dimension LWORK * On exit, if LWORK = -1, WORK(1) returns an estimate of * the optimal value for LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK .GE. max(1,N) * is sufficient, but LWORK typically as large as 6*N may * be required for optimal performance. A workspace query * to determine the optimal workspace size is recommended. * * If LWORK = -1, then ZLAQR4 does a workspace query. * In this case, ZLAQR4 checks the input parameters and * estimates the optimal workspace size for the given * values of N, ILO and IHI. The estimate is returned * in WORK(1). No error message related to LWORK is * issued by XERBLA. Neither H nor Z are accessed. * * * INFO (output) INTEGER * = 0: successful exit * .GT. 0: if INFO = i, ZLAQR4 failed to compute all of * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR * and WI contain those eigenvalues which have been * successfully computed. (Failures are rare.) * * If INFO .GT. 0 and WANT is .FALSE., then on exit, * the remaining unconverged eigenvalues are the eigen- * values of the upper Hessenberg matrix rows and * columns ILO through INFO of the final, output * value of H. * * If INFO .GT. 0 and WANTT is .TRUE., then on exit * * (*) (initial value of H)*U = U*(final value of H) * * where U is a unitary matrix. The final * value of H is upper Hessenberg and triangular in * rows and columns INFO+1 through IHI. * * If INFO .GT. 0 and WANTZ is .TRUE., then on exit * * (final value of Z(ILO:IHI,ILOZ:IHIZ) * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U * * where U is the unitary matrix in (*) (regard- * less of the value of WANTT.) * * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not * accessed. * * ================================================================ * Based on contributions by * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * * ================================================================ * References: * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 * Performance, SIAM Journal of Matrix Analysis, volume 23, pages * 929--947, 2002. * * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR * Algorithm Part II: Aggressive Early Deflation, SIAM Journal * of Matrix Analysis, volume 23, pages 948--973, 2002. * * ================================================================ * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . ZLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== * * ==== Exceptional deflation windows: try to cure rare * . slow convergence by increasing the size of the * . deflation window after KEXNW iterations. ===== * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. * . The constants WILK1 and WILK2 are used to form the * . exceptional shifts. ==== * INTEGER NTINY PARAMETER ( NTINY = 11 ) INTEGER KEXNW, KEXSH PARAMETER ( KEXNW = 5, KEXSH = 6 ) DOUBLE PRECISION WILK1 PARAMETER ( WILK1 = 0.75d0 ) COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 DOUBLE PRECISION S INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, $ NSR, NVE, NW, NWMAX, NWR LOGICAL NWINC, SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Local Arrays .. COMPLEX*16 ZDUM( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, $ SQRT * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. INFO = 0 * * ==== Quick return for N = 0: nothing to do. ==== * IF( N.EQ.0 ) THEN WORK( 1 ) = ONE RETURN END IF * * ==== Set up job flags for ILAENV. ==== * IF( WANTT ) THEN JBCMPZ( 1: 1 ) = 'S' ELSE JBCMPZ( 1: 1 ) = 'E' END IF IF( WANTZ ) THEN JBCMPZ( 2: 2 ) = 'V' ELSE JBCMPZ( 2: 2 ) = 'N' END IF * * ==== Tiny matrices must use ZLAHQR. ==== * IF( N.LE.NTINY ) THEN * * ==== Estimate optimal workspace. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) ELSE * * ==== Use small bulge multi-shift QR with aggressive early * . deflation on larger-than-tiny matrices. ==== * * ==== Hope for the best. ==== * INFO = 0 * * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. * . (In fact, there is enough subdiagonal space for * . NWR.GE.3.) ==== * NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) NW = NWR * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at * . enough subdiagonal workspace for NSR to be even * . and greater than or equal to two as required. ==== * NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) * * ==== Estimate optimal workspace ==== * * ==== Workspace query call to ZLAQR2 ==== * CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, $ LDH, WORK, -1 ) * * ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ==== * LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DCMPLX( LWKOPT, 0 ) RETURN END IF * * ==== ZLAHQR/ZLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== Nibble crossover point ==== * NIBBLE = ILAENV( 14, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NIBBLE = MAX( 0, NIBBLE ) * * ==== Accumulate reflections during ttswp? Use block * . 2-by-2 structure during matrix-matrix multiply? ==== * KACC22 = ILAENV( 16, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) KACC22 = MAX( 0, KACC22 ) KACC22 = MIN( 2, KACC22 ) * * ==== NWMAX = the largest possible deflation window for * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== * NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) NSMAX = NSMAX - MOD( NSMAX, 2 ) * * ==== NDFL: an iteration count restarted at deflation. ==== * NDFL = 1 * * ==== ITMAX = iteration limit ==== * ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) * * ==== Last row and column in the active block ==== * KBOT = IHI * * ==== Main Loop ==== * DO 70 IT = 1, ITMAX * * ==== Done when KBOT falls below ILO ==== * IF( KBOT.LT.ILO ) $ GO TO 80 * * ==== Locate active block ==== * DO 10 K = KBOT, ILO + 1, -1 IF( H( K, K-1 ).EQ.ZERO ) $ GO TO 20 10 CONTINUE K = ILO 20 CONTINUE KTOP = K * * ==== Select deflation window size ==== * NH = KBOT - KTOP + 1 IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN * * ==== Typical deflation window. If possible and * . advisable, nibble the entire active block. * . If not, use size NWR or NWR+1 depending upon * . which has the smaller corresponding subdiagonal * . entry (a heuristic). ==== * NWINC = .TRUE. IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN NW = NH ELSE NW = MIN( NWR, NH, NWMAX ) IF( NW.LT.NWMAX ) THEN IF( NW.GE.NH-1 ) THEN NW = NH ELSE KWTOP = KBOT - NW + 1 IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF END IF ELSE * * ==== Exceptional deflation window. If there have * . been no deflations in KEXNW or more iterations, * . then vary the deflation window size. At first, * . because, larger windows are, in general, more * . powerful than smaller ones, rapidly increase the * . window up to the maximum reasonable and possible. * . Then maybe try a slightly smaller window. ==== * IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN NW = MIN( NWMAX, NH, 2*NW ) ELSE NWINC = .FALSE. IF( NW.EQ.NH .AND. NH.GT.2 ) $ NW = NH - 1 END IF END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into * . - an nw-by-nw work array V in the lower * . left-hand-corner, * . - an NW-by-at-least-NW-but-more-is-better * . (NW-by-NHO) horizontal work array along * . the bottom edge, * . - an at-least-NW-but-more-is-better (NHV-by-NW) * . vertical work array along the left-hand-edge. * . ==== * KV = N - NW + 1 KT = NW + 1 NHO = ( N-NW-1 ) - KT + 1 KWV = NW + 2 NVE = ( N-NW ) - KWV + 1 * * ==== Aggressive early deflation ==== * CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, $ LWORK ) * * ==== Adjust KBOT accounting for new deflations. ==== * KBOT = KBOT - LD * * ==== KS points to the shifts. ==== * KS = KBOT - LS + 1 * * ==== Skip an expensive QR sweep if there is a (partly * . heuristic) reason to expect that many eigenvalues * . will deflate without it. Here, the QR sweep is * . skipped if many eigenvalues have just been deflated * . or if the remaining active block is small. * IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN * * ==== NS = nominal number of simultaneous shifts. * . This may be lowered (slightly) if ZLAQR2 * . did not provide that many shifts. ==== * NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) NS = NS - MOD( NS, 2 ) * * ==== If there have been no deflations * . in a multiple of KEXSH iterations, * . then try exceptional shifts. * . Otherwise use shifts provided by * . ZLAQR2 above or from the eigenvalues * . of a trailing principal submatrix. ==== * IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN KS = KBOT - NS + 1 DO 30 I = KBOT, KS + 1, -2 W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) W( I-1 ) = W( I ) 30 CONTINUE ELSE * * ==== Got NS/2 or fewer shifts? Use ZLAHQR * . on a trailing principal submatrix to * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, * . there is enough space below the subdiagonal * . to fit an NS-by-NS scratch array.) ==== * IF( KBOT-KS+1.LE.NS / 2 ) THEN KS = KBOT - NS + 1 KT = N - NS + 1 CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, $ H( KT, 1 ), LDH ) CALL ZLAHQR( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM, $ 1, INF ) KS = KS + INF * * ==== In case of a rare QR failure use * . eigenvalues of the trailing 2-by-2 * . principal submatrix. Scale to avoid * . overflows, underflows and subnormals. * . (The scale factor S can not be zero, * . because H(KBOT,KBOT-1) is nonzero.) ==== * IF( KS.GE.KBOT ) THEN S = CABS1( H( KBOT-1, KBOT-1 ) ) + $ CABS1( H( KBOT, KBOT-1 ) ) + $ CABS1( H( KBOT-1, KBOT ) ) + $ CABS1( H( KBOT, KBOT ) ) AA = H( KBOT-1, KBOT-1 ) / S CC = H( KBOT, KBOT-1 ) / S BB = H( KBOT-1, KBOT ) / S DD = H( KBOT, KBOT ) / S TR2 = ( AA+DD ) / TWO DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC RTDISC = SQRT( -DET ) W( KBOT-1 ) = ( TR2+RTDISC )*S W( KBOT ) = ( TR2-RTDISC )*S * KS = KBOT - 1 END IF END IF * IF( KBOT-KS+1.GT.NS ) THEN * * ==== Sort the shifts (Helps a little) ==== * SORTED = .false. DO 50 K = KBOT, KS + 1, -1 IF( SORTED ) $ GO TO 60 SORTED = .true. DO 40 I = KS, K - 1 IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) $ THEN SORTED = .false. SWAP = W( I ) W( I ) = W( I+1 ) W( I+1 ) = SWAP END IF 40 CONTINUE 50 CONTINUE 60 CONTINUE END IF END IF * * ==== If there are only two shifts, then use * . only one. ==== * IF( KBOT-KS+1.EQ.2 ) THEN IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN W( KBOT-1 ) = W( KBOT ) ELSE W( KBOT ) = W( KBOT-1 ) END IF END IF * * ==== Use up to NS of the the smallest magnatiude * . shifts. If there aren't NS shifts available, * . then use them all, possibly dropping one to * . make the number of shifts even. ==== * NS = MIN( NS, KBOT-KS+1 ) NS = NS - MOD( NS, 2 ) KS = KBOT - NS + 1 * * ==== Small-bulge multi-shift QR sweep: * . split workspace under the subdiagonal into * . - a KDU-by-KDU work array U in the lower * . left-hand-corner, * . - a KDU-by-at-least-KDU-but-more-is-better * . (KDU-by-NHo) horizontal work array WH along * . the bottom edge, * . - and an at-least-KDU-but-more-is-better-by-KDU * . (NVE-by-KDU) vertical work WV arrow along * . the left-hand-edge. ==== * KDU = 3*NS - 3 KU = N - KDU + 1 KWH = KDU + 1 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 KWV = KDU + 4 NVE = N - KDU - KWV + 1 * * ==== Small-bulge multi-shift QR sweep ==== * CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, $ NHO, H( KU, KWH ), LDH ) END IF * * ==== Note progress (or the lack of it). ==== * IF( LD.GT.0 ) THEN NDFL = 1 ELSE NDFL = NDFL + 1 END IF * * ==== End of main loop ==== 70 CONTINUE * * ==== Iteration limit exceeded. Set INFO to show where * . the problem occurred and exit. ==== * INFO = KBOT 80 CONTINUE END IF * * ==== Return the optimal value of LWORK. ==== * WORK( 1 ) = DCMPLX( LWKOPT, 0 ) * * ==== End of ZLAQR4 ==== * END SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, $ WV, LDWV, NH, WH, LDWH ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) * .. * * This auxiliary subroutine called by ZLAQR0 performs a * single small-bulge multi-shift QR sweep. * * WANTT (input) logical scalar * WANTT = .true. if the triangular Schur factor * is being computed. WANTT is set to .false. otherwise. * * WANTZ (input) logical scalar * WANTZ = .true. if the unitary Schur factor is being * computed. WANTZ is set to .false. otherwise. * * KACC22 (input) integer with value 0, 1, or 2. * Specifies the computation mode of far-from-diagonal * orthogonal updates. * = 0: ZLAQR5 does not accumulate reflections and does not * use matrix-matrix multiply to update far-from-diagonal * matrix entries. * = 1: ZLAQR5 accumulates reflections and uses matrix-matrix * multiply to update the far-from-diagonal matrix entries. * = 2: ZLAQR5 accumulates reflections, uses matrix-matrix * multiply to update the far-from-diagonal matrix entries, * and takes advantage of 2-by-2 block structure during * matrix multiplies. * * N (input) integer scalar * N is the order of the Hessenberg matrix H upon which this * subroutine operates. * * KTOP (input) integer scalar * KBOT (input) integer scalar * These are the first and last rows and columns of an * isolated diagonal block upon which the QR sweep is to be * applied. It is assumed without a check that * either KTOP = 1 or H(KTOP,KTOP-1) = 0 * and * either KBOT = N or H(KBOT+1,KBOT) = 0. * * NSHFTS (input) integer scalar * NSHFTS gives the number of simultaneous shifts. NSHFTS * must be positive and even. * * S (input) COMPLEX*16 array of size (NSHFTS) * S contains the shifts of origin that define the multi- * shift QR sweep. * * H (input/output) COMPLEX*16 array of size (LDH,N) * On input H contains a Hessenberg matrix. On output a * multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied * to the isolated diagonal block in rows and columns KTOP * through KBOT. * * LDH (input) integer scalar * LDH is the leading dimension of H just as declared in the * calling procedure. LDH.GE.MAX(1,N). * * ILOZ (input) INTEGER * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N * * Z (input/output) COMPLEX*16 array of size (LDZ,IHI) * If WANTZ = .TRUE., then the QR Sweep unitary * similarity transformation is accumulated into * Z(ILOZ:IHIZ,ILO:IHI) from the right. * If WANTZ = .FALSE., then Z is unreferenced. * * LDZ (input) integer scalar * LDA is the leading dimension of Z just as declared in * the calling procedure. LDZ.GE.N. * * V (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2) * * LDV (input) integer scalar * LDV is the leading dimension of V as declared in the * calling procedure. LDV.GE.3. * * U (workspace) COMPLEX*16 array of size * (LDU,3*NSHFTS-3) * * LDU (input) integer scalar * LDU is the leading dimension of U just as declared in the * in the calling subroutine. LDU.GE.3*NSHFTS-3. * * NH (input) integer scalar * NH is the number of columns in array WH available for * workspace. NH.GE.1. * * WH (workspace) COMPLEX*16 array of size (LDWH,NH) * * LDWH (input) integer scalar * Leading dimension of WH just as declared in the * calling procedure. LDWH.GE.3*NSHFTS-3. * * NV (input) integer scalar * NV is the number of rows in WV agailable for workspace. * NV.GE.1. * * WV (workspace) COMPLEX*16 array of size * (LDWV,3*NSHFTS-3) * * LDWV (input) integer scalar * LDWV is the leading dimension of WV as declared in the * in the calling subroutine. LDWV.GE.NV. * * ================================================================ * Based on contributions by * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * * ============================================================ * Reference: * * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR * Algorithm Part I: Maintaining Well Focused Shifts, and * Level 3 Performance, SIAM Journal of Matrix Analysis, * volume 23, pages 929--947, 2002. * * ============================================================ * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), $ ONE = ( 1.0d0, 0.0d0 ) ) DOUBLE PRECISION RZERO, RONE PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) * .. * .. Local Scalars .. COMPLEX*16 ALPHA, BETA, CDUM, REFSUM DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL, $ SMLNUM, TST1, TST2, ULP INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, $ NS, NU LOGICAL ACCUM, BLK22, BMP22 * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. * INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD * .. * .. Local Arrays .. COMPLEX*16 VT( 3 ) * .. * .. External Subroutines .. EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET, $ ZTRMM * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * * ==== If there are no shifts, then there is nothing to do. ==== * IF( NSHFTS.LT.2 ) $ RETURN * * ==== If the active block is empty or 1-by-1, then there * . is nothing to do. ==== * IF( KTOP.GE.KBOT ) $ RETURN * * ==== NSHFTS is supposed to be even, but if is odd, * . then simply reduce it by one. ==== * NS = NSHFTS - MOD( NSHFTS, 2 ) * * ==== Machine constants for deflation ==== * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( N ) / ULP ) * * ==== Use accumulated reflections to update far-from-diagonal * . entries ? ==== * ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) * * ==== If so, exploit the 2-by-2 block structure? ==== * BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) * * ==== clear trash ==== * IF( KTOP+2.LE.KBOT ) $ H( KTOP+2, KTOP ) = ZERO * * ==== NBMPS = number of 2-shift bulges in the chain ==== * NBMPS = NS / 2 * * ==== KDU = width of slab ==== * KDU = 6*NBMPS - 3 * * ==== Create and chase chains of NBMPS bulges ==== * DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 NDCOL = INCOL + KDU IF( ACCUM ) $ CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) * * ==== Near-the-diagonal bulge chase. The following loop * . performs the near-the-diagonal part of a small bulge * . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal * . chunk extends from column INCOL to column NDCOL * . (including both column INCOL and column NDCOL). The * . following loop chases a 3*NBMPS column long chain of * . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL * . may be less than KTOP and and NDCOL may be greater than * . KBOT indicating phantom columns from which to chase * . bulges before they are actually introduced or to which * . to chase bulges beyond column KBOT.) ==== * DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) * * ==== Bulges number MTOP to MBOT are active double implicit * . shift bulges. There may or may not also be small * . 2-by-2 bulge, if there is room. The inactive bulges * . (if any) must wait until the active bulges have moved * . down the diagonal to make room. The phantom matrix * . paradigm described above helps keep track. ==== * MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) M22 = MBOT + 1 BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. $ ( KBOT-2 ) * * ==== Generate reflections to chase the chain right * . one column. (The minimum value of K is KTOP-1.) ==== * DO 10 M = MTOP, MBOT K = KRCOL + 3*( M-1 ) IF( K.EQ.KTOP-1 ) THEN CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ), $ S( 2*M ), V( 1, M ) ) ALPHA = V( 1, M ) CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) ELSE BETA = H( K+1, K ) V( 2, M ) = H( K+2, K ) V( 3, M ) = H( K+3, K ) CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) * * ==== A Bulge may collapse because of vigilant * . deflation or destructive underflow. (The * . initial bulge is always collapsed.) Use * . the two-small-subdiagonals trick to try * . to get it started again. If V(2,M).NE.0 and * . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then * . this bulge is collapsing into a zero * . subdiagonal. It will be restarted next * . trip through the loop.) * IF( V( 1, M ).NE.ZERO .AND. $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3, $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) ) $ THEN * * ==== Typical case: not collapsed (yet). ==== * H( K+1, K ) = BETA H( K+2, K ) = ZERO H( K+3, K ) = ZERO ELSE * * ==== Atypical case: collapsed. Attempt to * . reintroduce ignoring H(K+1,K). If the * . fill resulting from the new reflector * . is too large, then abandon it. * . Otherwise, use the new one. ==== * CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), $ S( 2*M ), VT ) SCL = CABS1( VT( 1 ) ) + CABS1( VT( 2 ) ) + $ CABS1( VT( 3 ) ) IF( SCL.NE.RZERO ) THEN VT( 1 ) = VT( 1 ) / SCL VT( 2 ) = VT( 2 ) / SCL VT( 3 ) = VT( 3 ) / SCL END IF * * ==== The following is the traditional and * . conservative two-small-subdiagonals * . test. ==== * . IF( CABS1( H( K+1, K ) )* $ ( CABS1( VT( 2 ) )+CABS1( VT( 3 ) ) ).GT.ULP* $ CABS1( VT( 1 ) )*( CABS1( H( K, $ K ) )+CABS1( H( K+1, K+1 ) )+CABS1( H( K+2, $ K+2 ) ) ) ) THEN * * ==== Starting a new bulge here would * . create non-negligible fill. If * . the old reflector is diagonal (only * . possible with underflows), then * . change it to I. Otherwise, use * . it with trepidation. ==== * IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) $ THEN V( 1, M ) = ZERO ELSE H( K+1, K ) = BETA H( K+2, K ) = ZERO H( K+3, K ) = ZERO END IF ELSE * * ==== Stating a new bulge here would * . create only negligible fill. * . Replace the old reflector with * . the new one. ==== * ALPHA = VT( 1 ) CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) REFSUM = H( K+1, K ) + $ H( K+2, K )*DCONJG( VT( 2 ) ) + $ H( K+3, K )*DCONJG( VT( 3 ) ) H( K+1, K ) = H( K+1, K ) - $ DCONJG( VT( 1 ) )*REFSUM H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) V( 2, M ) = VT( 2 ) V( 3, M ) = VT( 3 ) END IF END IF END IF 10 CONTINUE * * ==== Generate a 2-by-2 reflection, if needed. ==== * K = KRCOL + 3*( M22-1 ) IF( BMP22 ) THEN IF( K.EQ.KTOP-1 ) THEN CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ), $ S( 2*M22 ), V( 1, M22 ) ) BETA = V( 1, M22 ) CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) ELSE BETA = H( K+1, K ) V( 2, M22 ) = H( K+2, K ) CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) H( K+1, K ) = BETA H( K+2, K ) = ZERO END IF ELSE * * ==== Initialize V(1,M22) here to avoid possible undefined * . variable problems later. ==== * V( 1, M22 ) = ZERO END IF * * ==== Multiply H by reflections from the left ==== * IF( ACCUM ) THEN JBOT = MIN( NDCOL, KBOT ) ELSE IF( WANTT ) THEN JBOT = N ELSE JBOT = KBOT END IF DO 30 J = MAX( KTOP, KRCOL ), JBOT MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) DO 20 M = MTOP, MEND K = KRCOL + 3*( M-1 ) REFSUM = DCONJG( V( 1, M ) )* $ ( H( K+1, J )+DCONJG( V( 2, M ) )* $ H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) ) H( K+1, J ) = H( K+1, J ) - REFSUM H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) 20 CONTINUE 30 CONTINUE IF( BMP22 ) THEN K = KRCOL + 3*( M22-1 ) DO 40 J = MAX( K+1, KTOP ), JBOT REFSUM = DCONJG( V( 1, M22 ) )* $ ( H( K+1, J )+DCONJG( V( 2, M22 ) )* $ H( K+2, J ) ) H( K+1, J ) = H( K+1, J ) - REFSUM H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) 40 CONTINUE END IF * * ==== Multiply H by reflections from the right. * . Delay filling in the last row until the * . vigilant deflation check is complete. ==== * IF( ACCUM ) THEN JTOP = MAX( KTOP, INCOL ) ELSE IF( WANTT ) THEN JTOP = 1 ELSE JTOP = KTOP END IF DO 80 M = MTOP, MBOT IF( V( 1, M ).NE.ZERO ) THEN K = KRCOL + 3*( M-1 ) DO 50 J = JTOP, MIN( KBOT, K+3 ) REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) H( J, K+1 ) = H( J, K+1 ) - REFSUM H( J, K+2 ) = H( J, K+2 ) - $ REFSUM*DCONJG( V( 2, M ) ) H( J, K+3 ) = H( J, K+3 ) - $ REFSUM*DCONJG( V( 3, M ) ) 50 CONTINUE * IF( ACCUM ) THEN * * ==== Accumulate U. (If necessary, update Z later * . with with an efficient matrix-matrix * . multiply.) ==== * KMS = K - INCOL DO 60 J = MAX( 1, KTOP-INCOL ), KDU REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM U( J, KMS+2 ) = U( J, KMS+2 ) - $ REFSUM*DCONJG( V( 2, M ) ) U( J, KMS+3 ) = U( J, KMS+3 ) - $ REFSUM*DCONJG( V( 3, M ) ) 60 CONTINUE ELSE IF( WANTZ ) THEN * * ==== U is not accumulated, so update Z * . now by multiplying by reflections * . from the right. ==== * DO 70 J = ILOZ, IHIZ REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) Z( J, K+1 ) = Z( J, K+1 ) - REFSUM Z( J, K+2 ) = Z( J, K+2 ) - $ REFSUM*DCONJG( V( 2, M ) ) Z( J, K+3 ) = Z( J, K+3 ) - $ REFSUM*DCONJG( V( 3, M ) ) 70 CONTINUE END IF END IF 80 CONTINUE * * ==== Special case: 2-by-2 reflection (if needed) ==== * K = KRCOL + 3*( M22-1 ) IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN DO 90 J = JTOP, MIN( KBOT, K+3 ) REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* $ H( J, K+2 ) ) H( J, K+1 ) = H( J, K+1 ) - REFSUM H( J, K+2 ) = H( J, K+2 ) - $ REFSUM*DCONJG( V( 2, M22 ) ) 90 CONTINUE * IF( ACCUM ) THEN KMS = K - INCOL DO 100 J = MAX( 1, KTOP-INCOL ), KDU REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )* $ U( J, KMS+2 ) ) U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM U( J, KMS+2 ) = U( J, KMS+2 ) - $ REFSUM*DCONJG( V( 2, M22 ) ) 100 CONTINUE ELSE IF( WANTZ ) THEN DO 110 J = ILOZ, IHIZ REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* $ Z( J, K+2 ) ) Z( J, K+1 ) = Z( J, K+1 ) - REFSUM Z( J, K+2 ) = Z( J, K+2 ) - $ REFSUM*DCONJG( V( 2, M22 ) ) 110 CONTINUE END IF END IF * * ==== Vigilant deflation check ==== * MSTART = MTOP IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) $ MSTART = MSTART + 1 MEND = MBOT IF( BMP22 ) $ MEND = MEND + 1 IF( KRCOL.EQ.KBOT-2 ) $ MEND = MEND + 1 DO 120 M = MSTART, MEND K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) * * ==== The following convergence test requires that * . the tradition small-compared-to-nearby-diagonals * . criterion and the Ahues & Tisseur (LAWN 122, 1997) * . criteria both be satisfied. The latter improves * . accuracy in some examples. Falling back on an * . alternate convergence criterion when TST1 or TST2 * . is zero (as done here) is traditional but probably * . unnecessary. ==== * IF( H( K+1, K ).NE.ZERO ) THEN TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) ) IF( TST1.EQ.RZERO ) THEN IF( K.GE.KTOP+1 ) $ TST1 = TST1 + CABS1( H( K, K-1 ) ) IF( K.GE.KTOP+2 ) $ TST1 = TST1 + CABS1( H( K, K-2 ) ) IF( K.GE.KTOP+3 ) $ TST1 = TST1 + CABS1( H( K, K-3 ) ) IF( K.LE.KBOT-2 ) $ TST1 = TST1 + CABS1( H( K+2, K+1 ) ) IF( K.LE.KBOT-3 ) $ TST1 = TST1 + CABS1( H( K+3, K+1 ) ) IF( K.LE.KBOT-4 ) $ TST1 = TST1 + CABS1( H( K+4, K+1 ) ) END IF IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) $ THEN H12 = MAX( CABS1( H( K+1, K ) ), $ CABS1( H( K, K+1 ) ) ) H21 = MIN( CABS1( H( K+1, K ) ), $ CABS1( H( K, K+1 ) ) ) H11 = MAX( CABS1( H( K+1, K+1 ) ), $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) H22 = MIN( CABS1( H( K+1, K+1 ) ), $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) SCL = H11 + H12 TST2 = H22*( H11 / SCL ) * IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE. $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO END IF END IF 120 CONTINUE * * ==== Fill in the last row of each bulge. ==== * MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) DO 130 M = MTOP, MEND K = KRCOL + 3*( M-1 ) REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) H( K+4, K+1 ) = -REFSUM H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) ) H( K+4, K+3 ) = H( K+4, K+3 ) - $ REFSUM*DCONJG( V( 3, M ) ) 130 CONTINUE * * ==== End of near-the-diagonal bulge chase. ==== * 140 CONTINUE * * ==== Use U (if accumulated) to update far-from-diagonal * . entries in H. If required, use U to update Z as * . well. ==== * IF( ACCUM ) THEN IF( WANTT ) THEN JTOP = 1 JBOT = N ELSE JTOP = KTOP JBOT = KBOT END IF IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN * * ==== Updates not exploiting the 2-by-2 block * . structure of U. K1 and NU keep track of * . the location and size of U in the special * . cases of introducing bulges and chasing * . bulges off the bottom. In these special * . cases and in case the number of shifts * . is NS = 2, there is no 2-by-2 block * . structure to exploit. ==== * K1 = MAX( 1, KTOP-INCOL ) NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 * * ==== Horizontal Multiply ==== * DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH JLEN = MIN( NH, JBOT-JCOL+1 ) CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, $ LDWH ) CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH, $ H( INCOL+K1, JCOL ), LDH ) 150 CONTINUE * * ==== Vertical multiply ==== * DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), $ LDU, ZERO, WV, LDWV ) CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, $ H( JROW, INCOL+K1 ), LDH ) 160 CONTINUE * * ==== Z multiply (also vertical) ==== * IF( WANTZ ) THEN DO 170 JROW = ILOZ, IHIZ, NV JLEN = MIN( NV, IHIZ-JROW+1 ) CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), $ LDU, ZERO, WV, LDWV ) CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, $ Z( JROW, INCOL+K1 ), LDZ ) 170 CONTINUE END IF ELSE * * ==== Updates exploiting U's 2-by-2 block structure. * . (I2, I4, J2, J4 are the last rows and columns * . of the blocks.) ==== * I2 = ( KDU+1 ) / 2 I4 = KDU J2 = I4 - I2 J4 = KDU * * ==== KZS and KNZ deal with the band of zeros * . along the diagonal of one of the triangular * . blocks. ==== * KZS = ( J4-J2 ) - ( NS+1 ) KNZ = NS + 1 * * ==== Horizontal multiply ==== * DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH JLEN = MIN( NH, JBOT-JCOL+1 ) * * ==== Copy bottom of H to top+KZS of scratch ==== * (The first KZS rows get multiplied by zero.) ==== * CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), $ LDH, WH( KZS+1, 1 ), LDWH ) * * ==== Multiply by U21' ==== * CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), $ LDWH ) * * ==== Multiply top of H by U11' ==== * CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) * * ==== Copy top of H bottom of WH ==== * CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, $ WH( I2+1, 1 ), LDWH ) * * ==== Multiply by U21' ==== * CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) * * ==== Multiply by U22 ==== * CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, $ U( J2+1, I2+1 ), LDU, $ H( INCOL+1+J2, JCOL ), LDH, ONE, $ WH( I2+1, 1 ), LDWH ) * * ==== Copy it back ==== * CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH, $ H( INCOL+1, JCOL ), LDH ) 180 CONTINUE * * ==== Vertical multiply ==== * DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) * * ==== Copy right of H to scratch (the first KZS * . columns get multiplied by zero) ==== * CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), $ LDH, WV( 1, 1+KZS ), LDWV ) * * ==== Multiply by U21 ==== * CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), $ LDWV ) * * ==== Multiply by U11 ==== * CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, $ LDWV ) * * ==== Copy left of H to right of scratch ==== * CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, $ WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U21 ==== * CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U22 ==== * CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, $ H( JROW, INCOL+1+J2 ), LDH, $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), $ LDWV ) * * ==== Copy it back ==== * CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, $ H( JROW, INCOL+1 ), LDH ) 190 CONTINUE * * ==== Multiply Z (also vertical) ==== * IF( WANTZ ) THEN DO 200 JROW = ILOZ, IHIZ, NV JLEN = MIN( NV, IHIZ-JROW+1 ) * * ==== Copy right of Z to left of scratch (first * . KZS columns get multiplied by zero) ==== * CALL ZLACPY( 'ALL', JLEN, KNZ, $ Z( JROW, INCOL+1+J2 ), LDZ, $ WV( 1, 1+KZS ), LDWV ) * * ==== Multiply by U12 ==== * CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, $ LDWV ) CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), $ LDWV ) * * ==== Multiply by U11 ==== * CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, $ WV, LDWV ) * * ==== Copy left of Z to right of scratch ==== * CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), $ LDZ, WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U21 ==== * CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), $ LDWV ) * * ==== Multiply by U22 ==== * CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, $ Z( JROW, INCOL+1+J2 ), LDZ, $ U( J2+1, I2+1 ), LDU, ONE, $ WV( 1, 1+I2 ), LDWV ) * * ==== Copy the result back to Z ==== * CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, $ Z( JROW, INCOL+1 ), LDZ ) 200 CONTINUE END IF END IF END IF 210 CONTINUE * * ==== End of ZLAQR5 ==== * END SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N COMPLEX*16 TAU * .. * .. Array Arguments .. COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * ZLARF applies a complex elementary reflector H to a complex M-by-N * matrix C, from either the left or the right. H is represented in the * form * * H = I - tau * v * v' * * where tau is a complex scalar and v is a complex vector. * * If tau = 0, then H is taken to be the unit matrix. * * To apply H' (the conjugate transpose of H), supply conjg(tau) instead * tau. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) COMPLEX*16 array, dimension * (1 + (M-1)*abs(INCV)) if SIDE = 'L' * or (1 + (N-1)*abs(INCV)) if SIDE = 'R' * The vector v in the representation of H. V is not used if * TAU = 0. * * INCV (input) INTEGER * The increment between elements of v. INCV <> 0. * * TAU (input) COMPLEX*16 * The value tau in the representation of H. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension * (N) if SIDE = 'L' * or (M) if SIDE = 'R' * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. External Subroutines .. EXTERNAL ZGEMV, ZGERC * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C * IF( TAU.NE.ZERO ) THEN * * w := C' * v * CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V, $ INCV, ZERO, WORK, 1 ) * * C := C - v * w' * CALL ZGERC( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( TAU.NE.ZERO ) THEN * * w := C * v * CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) * * C := C - w * v' * CALL ZGERC( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of ZLARF * END SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, LDC, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), $ WORK( LDWORK, * ) * .. * * Purpose * ======= * * ZLARFB applies a complex block reflector H or its transpose H' to a * complex M-by-N matrix C, from either the left or the right. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply H or H' from the Left * = 'R': apply H or H' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply H (No transpose) * = 'C': apply H' (Conjugate transpose) * * DIRECT (input) CHARACTER*1 * Indicates how H is formed from a product of elementary * reflectors * = 'F': H = H(1) H(2) . . . H(k) (Forward) * = 'B': H = H(k) . . . H(2) H(1) (Backward) * * STOREV (input) CHARACTER*1 * Indicates how the vectors which define the elementary * reflectors are stored: * = 'C': Columnwise * = 'R': Rowwise * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * K (input) INTEGER * The order of the matrix T (= the number of elementary * reflectors whose product defines the block reflector). * * V (input) COMPLEX*16 array, dimension * (LDV,K) if STOREV = 'C' * (LDV,M) if STOREV = 'R' and SIDE = 'L' * (LDV,N) if STOREV = 'R' and SIDE = 'R' * The matrix V. See further details. * * LDV (input) INTEGER * The leading dimension of the array V. * If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); * if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); * if STOREV = 'R', LDV >= K. * * T (input) COMPLEX*16 array, dimension (LDT,K) * The triangular K-by-K matrix T in the representation of the * block reflector. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= K. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by H*C or H'*C or C*H or C*H'. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K) * * LDWORK (input) INTEGER * The leading dimension of the array WORK. * If SIDE = 'L', LDWORK >= max(1,N); * if SIDE = 'R', LDWORK >= max(1,M). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. CHARACTER TRANST INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( LSAME( TRANS, 'N' ) ) THEN TRANST = 'C' ELSE TRANST = 'N' END IF * IF( LSAME( STOREV, 'C' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 ) (first K rows) * ( V2 ) * where V1 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) * * W := C1' * DO 10 J = 1, K CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) CALL ZLACGV( N, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2'*V2 * CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, $ K, M-K, ONE, C( K+1, 1 ), LDC, $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W' * IF( M.GT.K ) THEN * * C2 := C2 - V2 * W' * CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK, $ LDWORK, ONE, C( K+1, 1 ), LDC ) END IF * * W := W * V1' * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W' * DO 30 J = 1, K DO 20 I = 1, N C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 20 CONTINUE 30 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2 * CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V' * IF( N.GT.K ) THEN * * C2 := C2 - W * V2' * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ), $ LDV, ONE, C( 1, K+1 ), LDC ) END IF * * W := W * V1' * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE END IF * ELSE * * Let V = ( V1 ) * ( V2 ) (last K rows) * where V2 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) * * W := C2' * DO 70 J = 1, K CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) CALL ZLACGV( N, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1'*V1 * CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK, $ LDWORK ) END IF * * W := W * T' or W * T * CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W' * IF( M.GT.K ) THEN * * C1 := C1 - V1 * W' * CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, C, LDC ) END IF * * W := W * V2' * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, $ LDWORK ) * * C2 := C2 - W' * DO 90 J = 1, K DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ DCONJG( WORK( I, J ) ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V' * IF( N.GT.K ) THEN * * C1 := C1 - W * V1' * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE, $ C, LDC ) END IF * * W := W * V2' * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, $ LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K DO 110 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF END IF * ELSE IF( LSAME( STOREV, 'R' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 V2 ) (V1: first K columns) * where V1 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) * * W := C1' * DO 130 J = 1, K CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) CALL ZLACGV( N, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1' * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2'*V2' * CALL ZGEMM( 'Conjugate transpose', $ 'Conjugate transpose', N, K, M-K, ONE, $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, $ WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V' * W' * IF( M.GT.K ) THEN * * C2 := C2 - V2' * W' * CALL ZGEMM( 'Conjugate transpose', $ 'Conjugate transpose', M-K, N, K, -ONE, $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W' * DO 150 J = 1, K DO 140 I = 1, N C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 140 CONTINUE 150 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) * * W := C1 * DO 160 J = 1, K CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1' * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2' * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, $ K, N-K, ONE, C( 1, K+1 ), LDC, $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE * END IF * ELSE * * Let V = ( V1 V2 ) (V2: last K columns) * where V2 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) * * W := C2' * DO 190 J = 1, K CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) CALL ZLACGV( N, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2' * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, $ LDWORK ) IF( M.GT.K ) THEN * * W := W + C1'*V1' * CALL ZGEMM( 'Conjugate transpose', $ 'Conjugate transpose', N, K, M-K, ONE, C, $ LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V' * W' * IF( M.GT.K ) THEN * * C1 := C1 - V1' * W' * CALL ZGEMM( 'Conjugate transpose', $ 'Conjugate transpose', M-K, N, K, -ONE, V, $ LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W' * DO 210 J = 1, K DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ DCONJG( WORK( I, J ) ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) * * W := C2 * DO 220 J = 1, K CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2' * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, $ LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1' * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK, $ LDWORK ) END IF * * W := W * T or W * T' * CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C1 := C1 - W * V1 * CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * END IF * END IF END IF * RETURN * * End of ZLARFB * END SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N COMPLEX*16 ALPHA, TAU * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * Purpose * ======= * * ZLARFG generates a complex elementary reflector H of order n, such * that * * H' * ( alpha ) = ( beta ), H' * H = I. * ( x ) ( 0 ) * * where alpha and beta are scalars, with beta real, and x is an * (n-1)-element complex vector. H is represented in the form * * H = I - tau * ( 1 ) * ( 1 v' ) , * ( v ) * * where tau is a complex scalar and v is a complex (n-1)-element * vector. Note that H is not hermitian. * * If the elements of x are all zero and alpha is real, then tau = 0 * and H is taken to be the unit matrix. * * Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . * * Arguments * ========= * * N (input) INTEGER * The order of the elementary reflector. * * ALPHA (input/output) COMPLEX*16 * On entry, the value alpha. * On exit, it is overwritten with the value beta. * * X (input/output) COMPLEX*16 array, dimension * (1+(N-2)*abs(INCX)) * On entry, the vector x. * On exit, it is overwritten with the vector v. * * INCX (input) INTEGER * The increment between elements of X. INCX > 0. * * TAU (output) COMPLEX*16 * The value tau. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 COMPLEX*16 ZLADIV EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN * .. * .. External Subroutines .. EXTERNAL ZDSCAL, ZSCAL * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN TAU = ZERO RETURN END IF * XNORM = DZNRM2( N-1, X, INCX ) ALPHR = DBLE( ALPHA ) ALPHI = DIMAG( ALPHA ) * IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) RSAFMN = ONE / SAFMIN * IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * KNT = 0 10 CONTINUE KNT = KNT + 1 CALL ZDSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHI = ALPHI*RSAFMN ALPHR = ALPHR*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = DZNRM2( N-1, X, INCX ) ALPHA = DCMPLX( ALPHR, ALPHI ) BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) CALL ZSCAL( N-1, ALPHA, X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * ALPHA = BETA DO 20 J = 1, KNT ALPHA = ALPHA*SAFMIN 20 CONTINUE ELSE TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) CALL ZSCAL( N-1, ALPHA, X, INCX ) ALPHA = BETA END IF END IF * RETURN * * End of ZLARFG * END SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * Purpose * ======= * * ZLARFT forms the triangular factor T of a complex block reflector H * of order n, which is defined as a product of k elementary reflectors. * * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; * * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. * * If STOREV = 'C', the vector which defines the elementary reflector * H(i) is stored in the i-th column of the array V, and * * H = I - V * T * V' * * If STOREV = 'R', the vector which defines the elementary reflector * H(i) is stored in the i-th row of the array V, and * * H = I - V' * T * V * * Arguments * ========= * * DIRECT (input) CHARACTER*1 * Specifies the order in which the elementary reflectors are * multiplied to form the block reflector: * = 'F': H = H(1) H(2) . . . H(k) (Forward) * = 'B': H = H(k) . . . H(2) H(1) (Backward) * * STOREV (input) CHARACTER*1 * Specifies how the vectors which define the elementary * reflectors are stored (see also Further Details): * = 'C': columnwise * = 'R': rowwise * * N (input) INTEGER * The order of the block reflector H. N >= 0. * * K (input) INTEGER * The order of the triangular factor T (= the number of * elementary reflectors). K >= 1. * * V (input/output) COMPLEX*16 array, dimension * (LDV,K) if STOREV = 'C' * (LDV,N) if STOREV = 'R' * The matrix V. See further details. * * LDV (input) INTEGER * The leading dimension of the array V. * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i). * * T (output) COMPLEX*16 array, dimension (LDT,K) * The k by k triangular factor T of the block reflector. * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is * lower triangular. The rest of the array is not used. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= K. * * Further Details * =============== * * The shape of the matrix V and the storage of the vectors which define * the H(i) is best illustrated by the following example with n = 5 and * k = 3. The elements equal to 1 are not stored; the corresponding * array elements are modified but restored on exit. The rest of the * array is not used. * * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': * * V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) * ( v1 1 ) ( 1 v2 v2 v2 ) * ( v1 v2 1 ) ( 1 v3 v3 ) * ( v1 v2 v3 ) * ( v1 v2 v3 ) * * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': * * V = ( v1 v2 v3 ) V = ( v1 v1 1 ) * ( v1 v2 v3 ) ( v2 v2 v2 1 ) * ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) * ( 1 v3 ) * ( 1 ) * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, J COMPLEX*16 VII * .. * .. External Subroutines .. EXTERNAL ZGEMV, ZLACGV, ZTRMV * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 I = 1, K IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO 10 J = 1, I T( J, I ) = ZERO 10 CONTINUE ELSE * * general case * VII = V( I, I ) V( I, I ) = ONE IF( LSAME( STOREV, 'C' ) ) THEN * * T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) * CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, $ -TAU( I ), V( I, 1 ), LDV, V( I, I ), 1, $ ZERO, T( 1, I ), 1 ) ELSE * * T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' * IF( I.LT.N ) $ CALL ZLACGV( N-I, V( I, I+1 ), LDV ) CALL ZGEMV( '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 * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) * CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, $ LDT, T( 1, I ), 1 ) T( I, I ) = TAU( I ) END IF 20 CONTINUE ELSE DO 40 I = K, 1, -1 IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO 30 J = I, K T( J, I ) = ZERO 30 CONTINUE ELSE * * general case * IF( I.LT.K ) THEN IF( LSAME( STOREV, 'C' ) ) THEN VII = V( N-K+I, I ) V( N-K+I, I ) = ONE * * T(i+1:k,i) := * - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) * CALL ZGEMV( '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 * * T(i+1:k,i) := * - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' * CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV ) CALL ZGEMV( '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 * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) * CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) END IF T( I, I ) = TAU( I ) END IF 40 CONTINUE END IF RETURN * * End of ZLARFT * END SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER LDC, M, N COMPLEX*16 TAU * .. * .. Array Arguments .. COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * ZLARFX applies a complex elementary reflector H to a complex m by n * matrix C, from either the left or the right. H is represented in the * form * * H = I - tau * v * v' * * where tau is a complex scalar and v is a complex vector. * * If tau = 0, then H is taken to be the unit matrix * * This version uses inline code if H has order < 11. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) COMPLEX*16 array, dimension (M) if SIDE = 'L' * or (N) if SIDE = 'R' * The vector v in the representation of H. * * TAU (input) COMPLEX*16 * The value tau in the representation of H. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDA >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension (N) if SIDE = 'L' * or (M) if SIDE = 'R' * WORK is not referenced if H has order < 11. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER J COMPLEX*16 SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZGEMV, ZGERC * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * IF( TAU.EQ.ZERO ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C, where H has order m. * GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 )M * * Code for general M * * w := C'*v * CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V, 1, $ ZERO, WORK, 1 ) * * C := C - tau * v * w' * CALL ZGERC( M, N, -TAU, V, 1, WORK, 1, C, LDC ) GO TO 410 10 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) ) DO 20 J = 1, N C( 1, J ) = T1*C( 1, J ) 20 CONTINUE GO TO 410 30 CONTINUE * * Special code for 2 x 2 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) DO 40 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 40 CONTINUE GO TO 410 50 CONTINUE * * Special code for 3 x 3 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) DO 60 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 60 CONTINUE GO TO 410 70 CONTINUE * * Special code for 4 x 4 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) DO 80 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 80 CONTINUE GO TO 410 90 CONTINUE * * Special code for 5 x 5 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) DO 100 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 100 CONTINUE GO TO 410 110 CONTINUE * * Special code for 6 x 6 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) DO 120 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 120 CONTINUE GO TO 410 130 CONTINUE * * Special code for 7 x 7 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) V7 = DCONJG( V( 7 ) ) T7 = TAU*DCONJG( V7 ) DO 140 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 140 CONTINUE GO TO 410 150 CONTINUE * * Special code for 8 x 8 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) V7 = DCONJG( V( 7 ) ) T7 = TAU*DCONJG( V7 ) V8 = DCONJG( V( 8 ) ) T8 = TAU*DCONJG( V8 ) DO 160 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 160 CONTINUE GO TO 410 170 CONTINUE * * Special code for 9 x 9 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) V7 = DCONJG( V( 7 ) ) T7 = TAU*DCONJG( V7 ) V8 = DCONJG( V( 8 ) ) T8 = TAU*DCONJG( V8 ) V9 = DCONJG( V( 9 ) ) T9 = TAU*DCONJG( V9 ) DO 180 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 180 CONTINUE GO TO 410 190 CONTINUE * * Special code for 10 x 10 Householder * V1 = DCONJG( V( 1 ) ) T1 = TAU*DCONJG( V1 ) V2 = DCONJG( V( 2 ) ) T2 = TAU*DCONJG( V2 ) V3 = DCONJG( V( 3 ) ) T3 = TAU*DCONJG( V3 ) V4 = DCONJG( V( 4 ) ) T4 = TAU*DCONJG( V4 ) V5 = DCONJG( V( 5 ) ) T5 = TAU*DCONJG( V5 ) V6 = DCONJG( V( 6 ) ) T6 = TAU*DCONJG( V6 ) V7 = DCONJG( V( 7 ) ) T7 = TAU*DCONJG( V7 ) V8 = DCONJG( V( 8 ) ) T8 = TAU*DCONJG( V8 ) V9 = DCONJG( V( 9 ) ) T9 = TAU*DCONJG( V9 ) V10 = DCONJG( V( 10 ) ) T10 = TAU*DCONJG( V10 ) DO 200 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + $ V10*C( 10, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 C( 10, J ) = C( 10, J ) - SUM*T10 200 CONTINUE GO TO 410 ELSE * * Form C * H, where H has order n. * GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, $ 370, 390 )N * * Code for general N * * w := C * v * CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO, $ WORK, 1 ) * * C := C - tau * w * v' * CALL ZGERC( M, N, -TAU, WORK, 1, V, 1, C, LDC ) GO TO 410 210 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) ) DO 220 J = 1, M C( J, 1 ) = T1*C( J, 1 ) 220 CONTINUE GO TO 410 230 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) DO 240 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 240 CONTINUE GO TO 410 250 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) DO 260 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 260 CONTINUE GO TO 410 270 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) DO 280 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 280 CONTINUE GO TO 410 290 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) DO 300 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 300 CONTINUE GO TO 410 310 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) DO 320 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 320 CONTINUE GO TO 410 330 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) V7 = V( 7 ) T7 = TAU*DCONJG( V7 ) DO 340 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 340 CONTINUE GO TO 410 350 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) V7 = V( 7 ) T7 = TAU*DCONJG( V7 ) V8 = V( 8 ) T8 = TAU*DCONJG( V8 ) DO 360 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 360 CONTINUE GO TO 410 370 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) V7 = V( 7 ) T7 = TAU*DCONJG( V7 ) V8 = V( 8 ) T8 = TAU*DCONJG( V8 ) V9 = V( 9 ) T9 = TAU*DCONJG( V9 ) DO 380 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 380 CONTINUE GO TO 410 390 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*DCONJG( V1 ) V2 = V( 2 ) T2 = TAU*DCONJG( V2 ) V3 = V( 3 ) T3 = TAU*DCONJG( V3 ) V4 = V( 4 ) T4 = TAU*DCONJG( V4 ) V5 = V( 5 ) T5 = TAU*DCONJG( V5 ) V6 = V( 6 ) T6 = TAU*DCONJG( V6 ) V7 = V( 7 ) T7 = TAU*DCONJG( V7 ) V8 = V( 8 ) T8 = TAU*DCONJG( V8 ) V9 = V( 9 ) T9 = TAU*DCONJG( V9 ) V10 = V( 10 ) T10 = TAU*DCONJG( V10 ) DO 400 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + $ V10*C( J, 10 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 C( J, 10 ) = C( J, 10 ) - SUM*T10 400 CONTINUE GO TO 410 END IF 410 CONTINUE RETURN * * End of ZLARFX * END SUBROUTINE ZLARTG( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION CS COMPLEX*16 F, G, R, SN * .. * * Purpose * ======= * * ZLARTG generates a plane rotation so that * * [ CS SN ] [ F ] [ R ] * [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. * [ -SN CS ] [ G ] [ 0 ] * * This is a faster version of the BLAS1 routine ZROTG, except for * the following differences: * F and G are unchanged on return. * If G=0, then CS=1 and SN=0. * If F=0, then CS=0 and SN is chosen so that R is real. * * Arguments * ========= * * F (input) COMPLEX*16 * The first component of vector to be rotated. * * G (input) COMPLEX*16 * The second component of vector to be rotated. * * CS (output) DOUBLE PRECISION * The cosine of the rotation. * * SN (output) COMPLEX*16 * The sine of the rotation. * * R (output) COMPLEX*16 * The nonzero component of the rotated vector. * * Further Details * ======= ======= * * 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel * * This version has a few statements commented out for thread safety * (machine parameters are computed on each entry). 10 feb 03, SJH. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION TWO, ONE, ZERO PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. * LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, $ SAFMN2, SAFMX2, SCALE COMPLEX*16 FF, FS, GS * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG, $ MAX, SQRT * .. * .. Statement Functions .. DOUBLE PRECISION ABS1, ABSSQ * .. * .. Save statement .. * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. * DATA FIRST / .TRUE. / * .. * .. Statement Function definitions .. ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2 * .. * .. Executable Statements .. * * IF( FIRST ) THEN SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 * FIRST = .FALSE. * END IF SCALE = MAX( ABS1( F ), ABS1( G ) ) FS = F GS = G COUNT = 0 IF( SCALE.GE.SAFMX2 ) THEN 10 CONTINUE COUNT = COUNT + 1 FS = FS*SAFMN2 GS = GS*SAFMN2 SCALE = SCALE*SAFMN2 IF( SCALE.GE.SAFMX2 ) $ GO TO 10 ELSE IF( SCALE.LE.SAFMN2 ) THEN IF( G.EQ.CZERO ) THEN CS = ONE SN = CZERO R = F RETURN END IF 20 CONTINUE COUNT = COUNT - 1 FS = FS*SAFMX2 GS = GS*SAFMX2 SCALE = SCALE*SAFMX2 IF( SCALE.LE.SAFMN2 ) $ GO TO 20 END IF F2 = ABSSQ( FS ) G2 = ABSSQ( GS ) IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN * * This is a rare case: F is very small. * IF( F.EQ.CZERO ) THEN CS = ZERO R = DLAPY2( DBLE( G ), DIMAG( G ) ) * Do complex/real division explicitly with two real divisions D = DLAPY2( DBLE( GS ), DIMAG( GS ) ) SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D ) RETURN END IF F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) ) * G2 and G2S are accurate * G2 is at least SAFMIN, and G2S is at least SAFMN2 G2S = SQRT( G2 ) * Error in CS from underflow in F2S is at most * UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS * If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, * and so CS .lt. sqrt(SAFMIN) * If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN * and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) * Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S CS = F2S / G2S * Make sure abs(FF) = 1 * Do complex/real division explicitly with 2 real divisions IF( ABS1( F ).GT.ONE ) THEN D = DLAPY2( DBLE( F ), DIMAG( F ) ) FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D ) ELSE DR = SAFMX2*DBLE( F ) DI = SAFMX2*DIMAG( F ) D = DLAPY2( DR, DI ) FF = DCMPLX( DR / D, DI / D ) END IF SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S ) R = CS*F + SN*G ELSE * * This is the most common case. * Neither F2 nor F2/G2 are less than SAFMIN * F2S cannot overflow, and it is accurate * F2S = SQRT( ONE+G2 / F2 ) * Do the F2S(real)*FS(complex) multiply with two real multiplies R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) ) CS = ONE / F2S D = F2 + G2 * Do complex/real division explicitly with two real divisions SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D ) SN = SN*DCONJG( GS ) IF( COUNT.NE.0 ) THEN IF( COUNT.GT.0 ) THEN DO 30 I = 1, COUNT R = R*SAFMX2 30 CONTINUE ELSE DO 40 I = 1, -COUNT R = R*SAFMN2 40 CONTINUE END IF END IF END IF RETURN * * End of ZLARTG * END SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, KL, KU, LDA, M, N DOUBLE PRECISION CFROM, CTO * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLASCL multiplies the M by N complex matrix A by the real scalar * CTO/CFROM. This is done without over/underflow as long as the final * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that * A may be full, upper triangular, lower triangular, upper Hessenberg, * or banded. * * Arguments * ========= * * TYPE (input) CHARACTER*1 * TYPE indices the storage type of the input matrix. * = 'G': A is a full matrix. * = 'L': A is a lower triangular matrix. * = 'U': A is an upper triangular matrix. * = 'H': A is an upper Hessenberg matrix. * = 'B': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the lower * half stored. * = 'Q': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the upper * half stored. * = 'Z': A is a band matrix with lower bandwidth KL and upper * bandwidth KU. * * KL (input) INTEGER * The lower bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * KU (input) INTEGER * The upper bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * CFROM (input) DOUBLE PRECISION * CTO (input) DOUBLE PRECISION * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed * without over/underflow if the final result CTO*A(I,J)/CFROM * can be represented without over/underflow. CFROM must be * nonzero. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * INFO (output) INTEGER * 0 - successful exit * <0 - if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM CTO1 = CTOC / BIGNUM IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of ZLASCL * END SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, M, N COMPLEX*16 ALPHA, BETA * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLASET initializes a 2-D array A to BETA on the diagonal and * ALPHA on the offdiagonals. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be set. * = 'U': Upper triangular part is set. The lower triangle * is unchanged. * = 'L': Lower triangular part is set. The upper triangle * is unchanged. * Otherwise: All of the matrix A is set. * * M (input) INTEGER * On entry, M specifies the number of rows of A. * * N (input) INTEGER * On entry, N specifies the number of columns of A. * * ALPHA (input) COMPLEX*16 * All the offdiagonal array elements are set to ALPHA. * * BETA (input) COMPLEX*16 * All the diagonal array elements are set to BETA. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; * A(i,i) = BETA , 1 <= i <= min(m,n) * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN * * Set the diagonal to BETA and the strictly upper triangular * part of the array to ALPHA. * DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE DO 30 I = 1, MIN( N, M ) A( I, I ) = BETA 30 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN * * Set the diagonal to BETA and the strictly lower triangular * part of the array to ALPHA. * 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 * ELSE * * Set the array to BETA on the diagonal and ALPHA on the * offdiagonal. * 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 of ZLASET * END SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION C( * ), S( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLASR applies a sequence of real plane rotations to a complex matrix * A, from either the left or the right. * * When SIDE = 'L', the transformation takes the form * * A := P*A * * and when SIDE = 'R', the transformation takes the form * * A := A*P**T * * where P is an orthogonal matrix consisting of a sequence of z plane * rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', * and P**T is the transpose of P. * * When DIRECT = 'F' (Forward sequence), then * * P = P(z-1) * ... * P(2) * P(1) * * and when DIRECT = 'B' (Backward sequence), then * * P = P(1) * P(2) * ... * P(z-1) * * where P(k) is a plane rotation matrix defined by the 2-by-2 rotation * * R(k) = ( c(k) s(k) ) * = ( -s(k) c(k) ). * * When PIVOT = 'V' (Variable pivot), the rotation is performed * for the plane (k,k+1), i.e., P(k) has the form * * P(k) = ( 1 ) * ( ... ) * ( 1 ) * ( c(k) s(k) ) * ( -s(k) c(k) ) * ( 1 ) * ( ... ) * ( 1 ) * * where R(k) appears as a rank-2 modification to the identity matrix in * rows and columns k and k+1. * * When PIVOT = 'T' (Top pivot), the rotation is performed for the * plane (1,k+1), so P(k) has the form * * P(k) = ( c(k) s(k) ) * ( 1 ) * ( ... ) * ( 1 ) * ( -s(k) c(k) ) * ( 1 ) * ( ... ) * ( 1 ) * * where R(k) appears in rows and columns 1 and k+1. * * Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is * performed for the plane (k,z), giving P(k) the form * * P(k) = ( 1 ) * ( ... ) * ( 1 ) * ( c(k) s(k) ) * ( 1 ) * ( ... ) * ( 1 ) * ( -s(k) c(k) ) * * where R(k) appears in rows and columns k and z. The rotations are * performed without ever forming P(k) explicitly. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * Specifies whether the plane rotation matrix P is applied to * A on the left or the right. * = 'L': Left, compute A := P*A * = 'R': Right, compute A:= A*P**T * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation * matrix. * = 'V': Variable pivot, the plane (k,k+1) * = 'T': Top pivot, the plane (1,k+1) * = 'B': Bottom pivot, the plane (k,z) * * DIRECT (input) CHARACTER*1 * Specifies whether P is a forward or backward sequence of * plane rotations. * = 'F': Forward, P = P(z-1)*...*P(2)*P(1) * = 'B': Backward, P = P(1)*P(2)*...*P(z-1) * * M (input) INTEGER * The number of rows of the matrix A. If m <= 1, an immediate * return is effected. * * N (input) INTEGER * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * * C (input) DOUBLE PRECISION array, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' * The cosines c(k) of the plane rotations. * * S (input) DOUBLE PRECISION array, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' * The sines s(k) of the plane rotations. The 2-by-2 plane * rotation part of the matrix P(k), R(k), has the form * R(k) = ( c(k) s(k) ) * ( -s(k) c(k) ). * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * The M-by-N matrix A. On exit, A is overwritten by P*A if * SIDE = 'R' or by A*P**T if SIDE = 'L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J DOUBLE PRECISION CTEMP, STEMP COMPLEX*16 TEMP * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = 1 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN INFO = 2 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) $ THEN INFO = 3 ELSE IF( M.LT.0 ) THEN INFO = 4 ELSE IF( N.LT.0 ) THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = 9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLASR ', INFO ) RETURN END IF * * Quick return if possible * IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form P * A * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 10 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 10 CONTINUE END IF 20 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 40 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 30 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 30 CONTINUE END IF 40 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 60 J = 2, M CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 50 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 80 J = M, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 70 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 100 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 90 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 90 CONTINUE END IF 100 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 120 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 110 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form A * P' * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 140 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 130 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 130 CONTINUE END IF 140 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 160 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 150 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 150 CONTINUE END IF 160 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 180 J = 2, N CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 170 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 170 CONTINUE END IF 180 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 200 J = N, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 190 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 190 CONTINUE END IF 200 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 220 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 210 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 210 CONTINUE END IF 220 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 240 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 230 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 230 CONTINUE END IF 240 CONTINUE END IF END IF END IF * RETURN * * End of ZLASR * END SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION SCALE, SUMSQ * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * Purpose * ======= * * ZLASSQ returns the values scl and ssq such that * * ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, * * where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is * assumed to be at least unity and the value of ssq will then satisfy * * 1.0 .le. ssq .le. ( sumsq + 2*n ). * * scale is assumed to be non-negative and scl returns the value * * scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), * i * * scale and sumsq must be supplied in SCALE and SUMSQ respectively. * SCALE and SUMSQ are overwritten by scl and ssq respectively. * * The routine makes only one pass through the vector X. * * Arguments * ========= * * N (input) INTEGER * The number of elements to be used from the vector X. * * X (input) COMPLEX*16 array, dimension (N) * The vector x as described above. * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. * * INCX (input) INTEGER * The increment between successive values of the vector X. * INCX > 0. * * SCALE (input/output) DOUBLE PRECISION * On entry, the value scale in the equation above. * On exit, SCALE is overwritten with the value scl . * * SUMSQ (input/output) DOUBLE PRECISION * On entry, the value sumsq in the equation above. * On exit, SUMSQ is overwritten with the value ssq . * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER IX DOUBLE PRECISION TEMP1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG * .. * .. Executable Statements .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX IF( DBLE( X( IX ) ).NE.ZERO ) THEN TEMP1 = ABS( DBLE( 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( DIMAG( X( IX ) ).NE.ZERO ) THEN TEMP1 = ABS( DIMAG( 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 of ZLASSQ * END SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLASWP performs a series of row interchanges on the matrix A. * One row interchange is initiated for each of rows K1 through K2 of A. * * Arguments * ========= * * N (input) INTEGER * The number of columns of the matrix A. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the matrix of column dimension N to which the row * interchanges will be applied. * On exit, the permuted matrix. * * LDA (input) INTEGER * The leading dimension of the array A. * * K1 (input) INTEGER * The first element of IPIV for which a row interchange will * be done. * * K2 (input) INTEGER * The last element of IPIV for which a row interchange will * be done. * * IPIV (input) INTEGER array, dimension (K2*abs(INCX)) * The vector of pivot indices. Only the elements in positions * K1 through K2 of IPIV are accessed. * IPIV(K) = L implies rows K and L are to be interchanged. * * INCX (input) INTEGER * The increment between successive values of IPIV. If IPIV * is negative, the pivots are applied in reverse order. * * Further Details * =============== * * Modified by * R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA * * ===================================================================== * * .. Local Scalars .. INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 COMPLEX*16 TEMP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * IF( INCX.GT.0 ) THEN IX0 = K1 I1 = K1 I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN IX0 = 1 + ( 1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 ELSE RETURN END IF * N32 = ( N / 32 )*32 IF( N32.NE.0 ) THEN DO 30 J = 1, N32, 32 IX = IX0 DO 20 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 10 K = J, J + 31 TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 10 CONTINUE END IF IX = IX + INCX 20 CONTINUE 30 CONTINUE END IF IF( N32.NE.N ) THEN N32 = N32 + 1 IX = IX0 DO 50 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 40 K = N32, N TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 40 CONTINUE END IF IX = IX + INCX 50 CONTINUE END IF * RETURN * * End of ZLASWP * END SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, LDW, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION E( * ) COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * ) * .. * * Purpose * ======= * * ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to * Hermitian tridiagonal form by a unitary similarity * transformation Q' * A * Q, and returns the matrices V and W which are * needed to apply the transformation to the unreduced part of A. * * If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a * matrix, of which the upper triangle is supplied; * if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a * matrix, of which the lower triangle is supplied. * * This is an auxiliary routine called by ZHETRD. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * Hermitian matrix A is stored: * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrix A. * * NB (input) INTEGER * The number of rows and columns to be reduced. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the Hermitian matrix A. If UPLO = 'U', the leading * n-by-n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n-by-n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * On exit: * if UPLO = 'U', the last NB columns have been reduced to * tridiagonal form, with the diagonal elements overwriting * the diagonal elements of A; the elements above the diagonal * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors; * if UPLO = 'L', the first NB columns have been reduced to * tridiagonal form, with the diagonal elements overwriting * the diagonal elements of A; the elements below the diagonal * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * E (output) DOUBLE PRECISION array, dimension (N-1) * If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal * elements of the last NB columns of the reduced matrix; * if UPLO = 'L', E(1:nb) contains the subdiagonal elements of * the first NB columns of the reduced matrix. * * TAU (output) COMPLEX*16 array, dimension (N-1) * The scalar factors of the elementary reflectors, stored in * TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. * See Further Details. * * W (output) COMPLEX*16 array, dimension (LDW,NB) * The n-by-nb matrix W required to update the unreduced part * of A. * * LDW (input) INTEGER * The leading dimension of the array W. LDW >= max(1,N). * * Further Details * =============== * * If UPLO = 'U', the matrix Q is represented as a product of elementary * reflectors * * Q = H(n) H(n-1) . . . H(n-nb+1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), * and tau in TAU(i-1). * * If UPLO = 'L', the matrix Q is represented as a product of elementary * reflectors * * Q = H(1) H(2) . . . H(nb). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), * and tau in TAU(i). * * The elements of the vectors v together form the n-by-nb matrix V * which is needed, with W, to apply the transformation to the unreduced * part of the matrix, using a Hermitian rank-2k update of the form: * A := A - V*W' - W*V'. * * The contents of A on exit are illustrated by the following examples * with n = 5 and nb = 2: * * if UPLO = 'U': if UPLO = 'L': * * ( a a a v4 v5 ) ( d ) * ( a a v4 v5 ) ( 1 d ) * ( a 1 v5 ) ( v1 1 a ) * ( d 1 ) ( v1 v2 a a ) * ( d ) ( v1 v2 a a a ) * * where d denotes a diagonal element of the reduced matrix, a denotes * an element of the original matrix that is unchanged, and vi denotes * an element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE, HALF PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ), $ HALF = ( 0.5D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, IW COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL * .. * .. External Functions .. LOGICAL LSAME COMPLEX*16 ZDOTC EXTERNAL LSAME, ZDOTC * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.0 ) $ RETURN * IF( LSAME( UPLO, 'U' ) ) THEN * * Reduce last NB columns of upper triangle * DO 10 I = N, N - NB + 1, -1 IW = I - N + NB IF( I.LT.N ) THEN * * Update A(1:i,i) * A( I, I ) = DBLE( A( I, I ) ) CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) CALL ZLACGV( N-I, A( I, I+1 ), LDA ) CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) CALL ZLACGV( N-I, A( I, I+1 ), LDA ) A( I, I ) = DBLE( A( I, I ) ) END IF IF( I.GT.1 ) THEN * * Generate elementary reflector H(i) to annihilate * A(1:i-2,i) * ALPHA = A( I-1, I ) CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) ) E( I-1 ) = ALPHA A( I-1, I ) = ONE * * Compute W(1:i-1,i) * CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, $ ZERO, W( 1, IW ), 1 ) IF( I.LT.N ) THEN CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, $ W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO, $ W( I+1, IW ), 1 ) CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, $ W( 1, IW ), 1 ) CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, $ A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO, $ W( I+1, IW ), 1 ) CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, $ W( 1, IW ), 1 ) END IF CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1, $ A( 1, I ), 1 ) CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) END IF * 10 CONTINUE ELSE * * Reduce first NB columns of lower triangle * DO 20 I = 1, NB * * Update A(i:n,i) * A( I, I ) = DBLE( A( I, I ) ) CALL ZLACGV( I-1, W( I, 1 ), LDW ) CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) CALL ZLACGV( I-1, W( I, 1 ), LDW ) CALL ZLACGV( I-1, A( I, 1 ), LDA ) CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) CALL ZLACGV( I-1, A( I, 1 ), LDA ) A( I, I ) = DBLE( A( I, I ) ) IF( I.LT.N ) THEN * * Generate elementary reflector H(i) to annihilate * A(i+2:n,i) * ALPHA = A( I+1, I ) CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, $ TAU( I ) ) E( I ) = ALPHA A( I+1, I ) = ONE * * Compute W(i+1:n,i) * CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, $ W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO, $ W( 1, I ), 1 ) CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, $ W( 1, I ), 1 ) CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1, $ A( I+1, I ), 1 ) CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) END IF * 20 CONTINUE END IF * RETURN * * End of ZLATRD * END SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO INTEGER INFO, LDA, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. DOUBLE PRECISION CNORM( * ) COMPLEX*16 A( LDA, * ), X( * ) * .. * * Purpose * ======= * * ZLATRS solves one of the triangular systems * * A * x = s*b, A**T * x = s*b, or A**H * x = s*b, * * with scaling to prevent overflow. Here A is an upper or lower * triangular matrix, A**T denotes the transpose of A, A**H denotes the * conjugate transpose of A, x and b are n-element vectors, and s is a * scaling factor, usually less than or equal to 1, chosen so that the * components of x will be less than the overflow threshold. If the * unscaled problem will not cause overflow, the Level 2 BLAS routine * ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), * then s is set to 0 and a non-trivial solution to A*x = 0 is returned. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the matrix A is upper or lower triangular. * = 'U': Upper triangular * = 'L': Lower triangular * * TRANS (input) CHARACTER*1 * Specifies the operation applied to A. * = 'N': Solve A * x = s*b (No transpose) * = 'T': Solve A**T * x = s*b (Transpose) * = 'C': Solve A**H * x = s*b (Conjugate transpose) * * DIAG (input) CHARACTER*1 * Specifies whether or not the matrix A is unit triangular. * = 'N': Non-unit triangular * = 'U': Unit triangular * * NORMIN (input) CHARACTER*1 * Specifies whether CNORM has been set or not. * = 'Y': CNORM contains the column norms on entry * = 'N': CNORM is not set on entry. On exit, the norms will * be computed and stored in CNORM. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The triangular matrix A. If UPLO = 'U', the leading n by n * upper triangular part of the array A contains the upper * triangular matrix, and the strictly lower triangular part of * A is not referenced. If UPLO = 'L', the leading n by n lower * triangular part of the array A contains the lower triangular * matrix, and the strictly upper triangular part of A is not * referenced. If DIAG = 'U', the diagonal elements of A are * also not referenced and are assumed to be 1. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max (1,N). * * X (input/output) COMPLEX*16 array, dimension (N) * On entry, the right hand side b of the triangular system. * On exit, X is overwritten by the solution vector x. * * SCALE (output) DOUBLE PRECISION * The scaling factor s for the triangular system * A * x = s*b, A**T * x = s*b, or A**H * x = s*b. * If SCALE = 0, the matrix A is singular or badly scaled, and * the vector x is an exact or approximate solution to A*x = 0. * * CNORM (input or output) DOUBLE PRECISION array, dimension (N) * * If NORMIN = 'Y', CNORM is an input argument and CNORM(j) * contains the norm of the off-diagonal part of the j-th column * of A. If TRANS = 'N', CNORM(j) must be greater than or equal * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) * must be greater than or equal to the 1-norm. * * If NORMIN = 'N', CNORM is an output argument and CNORM(j) * returns the 1-norm of the offdiagonal part of the j-th column * of A. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * * Further Details * ======= ======= * * A rough bound on x is computed; if that is less than overflow, ZTRSV * is called, otherwise, specific code is used which checks for possible * overflow or divide-by-zero at every operation. * * A columnwise scheme is used for solving A*x = b. The basic algorithm * if A is lower triangular is * * x[1:n] := b[1:n] * for j = 1, ..., n * x(j) := x(j) / A(j,j) * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] * end * * Define bounds on the components of x after j iterations of the loop: * M(j) = bound on x[1:j] * G(j) = bound on x[j+1:n] * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. * * Then for iteration j+1 we have * M(j+1) <= G(j) / | A(j+1,j+1) | * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) * * where CNORM(j+1) is greater than or equal to the infinity-norm of * column j+1 of A, not counting the diagonal. Hence * * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) * 1<=i<=j * and * * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) * 1<=i< j * * Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the * reciprocal of the largest M(j), j=1,..,n, is larger than * max(underflow, 1/overflow). * * The bound on x(j) is also used to determine when a step in the * columnwise method can be performed without fear of overflow. If * the computed bound is greater than a large constant, x is scaled to * prevent overflow, but if the bound overflows, x is set to 0, x(j) to * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. * * Similarly, a row-wise scheme is used to solve A**T *x = b or * A**H *x = b. The basic algorithm for A upper triangular is * * for j = 1, ..., n * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) * end * * We simultaneously compute two bounds * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j * M(j) = bound on x(i), 1<=i<=j * * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. * Then the bound on x(j) is * * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | * * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) * 1<=i<=j * * and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater * than max(underflow, 1/overflow). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, TWO PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, $ TWO = 2.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER INTEGER I, IMAX, J, JFIRST, JINC, JLAST DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL, $ XBND, XJ, XMAX COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, IZAMAX DOUBLE PRECISION DLAMCH, DZASUM COMPLEX*16 ZDOTC, ZDOTU, ZLADIV EXTERNAL LSAME, IDAMAX, IZAMAX, DLAMCH, DZASUM, ZDOTC, $ ZDOTU, ZLADIV * .. * .. External Subroutines .. EXTERNAL DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN * .. * .. Statement Functions .. DOUBLE PRECISION CABS1, CABS2 * .. * .. Statement Function definitions .. CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) CABS2( ZDUM ) = ABS( DBLE( ZDUM ) / 2.D0 ) + $ ABS( DIMAG( ZDUM ) / 2.D0 ) * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * * Test the input parameters. * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. $ LSAME( NORMIN, 'N' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLATRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine machine dependent parameters to control overflow. * SMLNUM = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM SCALE = ONE * IF( LSAME( NORMIN, 'N' ) ) THEN * * Compute the 1-norm of each column, not including the diagonal. * IF( UPPER ) THEN * * A is upper triangular. * DO 10 J = 1, N CNORM( J ) = DZASUM( J-1, A( 1, J ), 1 ) 10 CONTINUE ELSE * * A is lower triangular. * DO 20 J = 1, N - 1 CNORM( J ) = DZASUM( N-J, A( J+1, J ), 1 ) 20 CONTINUE CNORM( N ) = ZERO END IF END IF * * Scale the column norms by TSCAL if the maximum element in CNORM is * greater than BIGNUM/2. * IMAX = IDAMAX( N, CNORM, 1 ) TMAX = CNORM( IMAX ) IF( TMAX.LE.BIGNUM*HALF ) THEN TSCAL = ONE ELSE TSCAL = HALF / ( SMLNUM*TMAX ) CALL DSCAL( N, TSCAL, CNORM, 1 ) END IF * * Compute a bound on the computed solution vector to see if the * Level 2 BLAS routine ZTRSV can be used. * XMAX = ZERO DO 30 J = 1, N XMAX = MAX( XMAX, CABS2( X( J ) ) ) 30 CONTINUE XBND = XMAX * IF( NOTRAN ) THEN * * Compute the growth in A * x = b. * IF( UPPER ) THEN JFIRST = N JLAST = 1 JINC = -1 ELSE JFIRST = 1 JLAST = N JINC = 1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 60 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, G(0) = max{x(i), i=1,...,n}. * GROW = HALF / MAX( XBND, SMLNUM ) XBND = GROW DO 40 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 60 * TJJS = A( J, J ) TJJ = CABS1( TJJS ) * IF( TJJ.GE.SMLNUM ) THEN * * M(j) = G(j-1) / abs(A(j,j)) * XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) ELSE * * M(j) could overflow, set XBND to 0. * XBND = ZERO END IF * IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN * * G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) * GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) ELSE * * G(j) could overflow, set GROW to 0. * GROW = ZERO END IF 40 CONTINUE GROW = XBND ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) DO 50 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 60 * * G(j) = G(j-1)*( 1 + CNORM(j) ) * GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) 50 CONTINUE END IF 60 CONTINUE * ELSE * * Compute the growth in A**T * x = b or A**H * x = b. * IF( UPPER ) THEN JFIRST = 1 JLAST = N JINC = 1 ELSE JFIRST = N JLAST = 1 JINC = -1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 90 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, M(0) = max{x(i), i=1,...,n}. * GROW = HALF / MAX( XBND, SMLNUM ) XBND = GROW DO 70 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 90 * * G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) * XJ = ONE + CNORM( J ) GROW = MIN( GROW, XBND / XJ ) * TJJS = A( J, J ) TJJ = CABS1( TJJS ) * IF( TJJ.GE.SMLNUM ) THEN * * M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) * IF( XJ.GT.TJJ ) $ XBND = XBND*( TJJ / XJ ) ELSE * * M(j) could overflow, set XBND to 0. * XBND = ZERO END IF 70 CONTINUE GROW = MIN( GROW, XBND ) ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) DO 80 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 90 * * G(j) = ( 1 + CNORM(j) )*G(j-1) * XJ = ONE + CNORM( J ) GROW = GROW / XJ 80 CONTINUE END IF 90 CONTINUE END IF * IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN * * Use the Level 2 BLAS solve if the reciprocal of the bound on * elements of X is not too small. * CALL ZTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) ELSE * * Use a Level 1 BLAS solve, scaling intermediate results. * IF( XMAX.GT.BIGNUM*HALF ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * SCALE = ( BIGNUM*HALF ) / XMAX CALL ZDSCAL( N, SCALE, X, 1 ) XMAX = BIGNUM ELSE XMAX = XMAX*TWO END IF * IF( NOTRAN ) THEN * * Solve A * x = b * DO 120 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) / A(j,j), scaling x if necessary. * XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 110 END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by 1/b(j). * REC = ONE / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = ZLADIV( X( J ), TJJS ) XJ = CABS1( X( J ) ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM * to avoid overflow when dividing by A(j,j). * REC = ( TJJ*BIGNUM ) / XJ IF( CNORM( J ).GT.ONE ) THEN * * Scale by 1/CNORM(j) to avoid overflow when * multiplying x(j) times column j. * REC = REC / CNORM( J ) END IF CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = ZLADIV( X( J ), TJJS ) XJ = CABS1( X( J ) ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A*x = 0. * DO 100 I = 1, N X( I ) = ZERO 100 CONTINUE X( J ) = ONE XJ = ONE SCALE = ZERO XMAX = ZERO END IF 110 CONTINUE * * Scale x if necessary to avoid overflow when adding a * multiple of column j of A. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * REC = REC*HALF CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN * * Scale x by 1/2. * CALL ZDSCAL( N, HALF, X, 1 ) SCALE = SCALE*HALF END IF * IF( UPPER ) THEN IF( J.GT.1 ) THEN * * Compute the update * x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) * CALL ZAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, $ 1 ) I = IZAMAX( J-1, X, 1 ) XMAX = CABS1( X( I ) ) END IF ELSE IF( J.LT.N ) THEN * * Compute the update * x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) * CALL ZAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, $ X( J+1 ), 1 ) I = J + IZAMAX( N-J, X( J+1 ), 1 ) XMAX = CABS1( X( I ) ) END IF END IF 120 CONTINUE * ELSE IF( LSAME( TRANS, 'T' ) ) THEN * * Solve A**T * x = b * DO 170 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = CABS1( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = ZLADIV( USCAL, TJJS ) END IF IF( REC.LT.ONE ) THEN CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * CSUMJ = ZERO IF( USCAL.EQ.DCMPLX( ONE ) ) THEN * * If the scaling needed for A in the dot product is 1, * call ZDOTU to perform the dot product. * IF( UPPER ) THEN CSUMJ = ZDOTU( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN CSUMJ = ZDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 130 I = 1, J - 1 CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) 130 CONTINUE ELSE IF( J.LT.N ) THEN DO 140 I = J + 1, N CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) 140 CONTINUE END IF END IF * IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN * * Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - CSUMJ XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 160 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = ZLADIV( X( J ), TJJS ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = ZLADIV( X( J ), TJJS ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0 and compute a solution to A**T *x = 0. * DO 150 I = 1, N X( I ) = ZERO 150 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 160 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot * product has already been divided by 1/A(j,j). * X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ END IF XMAX = MAX( XMAX, CABS1( X( J ) ) ) 170 CONTINUE * ELSE * * Solve A**H * x = b * DO 220 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = CABS1( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = DCONJG( A( J, J ) )*TSCAL ELSE TJJS = TSCAL END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = ZLADIV( USCAL, TJJS ) END IF IF( REC.LT.ONE ) THEN CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * CSUMJ = ZERO IF( USCAL.EQ.DCMPLX( ONE ) ) THEN * * If the scaling needed for A in the dot product is 1, * call ZDOTC to perform the dot product. * IF( UPPER ) THEN CSUMJ = ZDOTC( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN CSUMJ = ZDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 180 I = 1, J - 1 CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* $ X( I ) 180 CONTINUE ELSE IF( J.LT.N ) THEN DO 190 I = J + 1, N CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* $ X( I ) 190 CONTINUE END IF END IF * IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN * * Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - CSUMJ XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = DCONJG( A( J, J ) )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 210 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = ZLADIV( X( J ), TJJS ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = ZLADIV( X( J ), TJJS ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0 and compute a solution to A**H *x = 0. * DO 200 I = 1, N X( I ) = ZERO 200 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 210 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot * product has already been divided by 1/A(j,j). * X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ END IF XMAX = MAX( XMAX, CABS1( X( J ) ) ) 220 CONTINUE END IF SCALE = SCALE / TSCAL END IF * * Scale the column norms by 1/TSCAL for return. * IF( TSCAL.NE.ONE ) THEN CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) END IF * RETURN * * End of ZLATRS * END SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZPOTF2 computes the Cholesky factorization of a complex Hermitian * positive definite matrix A. * * The factorization has the form * A = U' * U , if UPLO = 'U', or * A = L * L', if UPLO = 'L', * where U is an upper triangular matrix and L is lower triangular. * * This is the unblocked version of the algorithm, calling Level 2 BLAS. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * Hermitian matrix A is stored. * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the Hermitian matrix A. If UPLO = 'U', the leading * n by n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n by n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, if INFO = 0, the factor U or L from the Cholesky * factorization A = U'*U or A = L*L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * > 0: if INFO = k, the leading minor of order k is not * positive definite, and the factorization could not be * completed. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J DOUBLE PRECISION AJJ * .. * .. External Functions .. LOGICAL LSAME COMPLEX*16 ZDOTC EXTERNAL LSAME, ZDOTC * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZLACGV * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZPOTF2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Compute the Cholesky factorization A = U'*U. * DO 10 J = 1, N * * Compute U(J,J) and test for non-positive-definiteness. * AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( 1, J ), 1, $ A( 1, J ), 1 ) IF( AJJ.LE.ZERO ) THEN A( J, J ) = AJJ GO TO 30 END IF AJJ = SQRT( AJJ ) A( J, J ) = AJJ * * Compute elements J+1:N of row J. * IF( J.LT.N ) THEN CALL ZLACGV( J-1, A( 1, J ), 1 ) CALL ZGEMV( '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 ZDSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) END IF 10 CONTINUE ELSE * * Compute the Cholesky factorization A = L*L'. * DO 20 J = 1, N * * Compute L(J,J) and test for non-positive-definiteness. * AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( J, 1 ), LDA, $ A( J, 1 ), LDA ) IF( AJJ.LE.ZERO ) THEN A( J, J ) = AJJ GO TO 30 END IF AJJ = SQRT( AJJ ) A( J, J ) = AJJ * * Compute elements J+1:N of column J. * IF( J.LT.N ) THEN CALL ZLACGV( J-1, A( J, 1 ), LDA ) CALL ZGEMV( '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 ZDSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) END IF 20 CONTINUE END IF GO TO 40 * 30 CONTINUE INFO = J * 40 CONTINUE RETURN * * End of ZPOTF2 * END SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZPOTRF computes the Cholesky factorization of a complex Hermitian * positive definite matrix A. * * The factorization has the form * A = U**H * U, if UPLO = 'U', or * A = L * L**H, if UPLO = 'L', * where U is an upper triangular matrix and L is lower triangular. * * This is the block version of the algorithm, calling Level 3 BLAS. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the Hermitian matrix A. If UPLO = 'U', the leading * N-by-N upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading N-by-N lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, if INFO = 0, the factor U or L from the Cholesky * factorization A = U**H*U or A = L*L**H. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, the leading minor of order i is not * positive definite, and the factorization could not be * completed. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE COMPLEX*16 CONE PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, JB, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEMM, ZHERK, ZPOTF2, ZTRSM * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZPOTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine the block size for this environment. * NB = ILAENV( 1, 'ZPOTRF', UPLO, N, -1, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.N ) THEN * * Use unblocked code. * CALL ZPOTF2( UPLO, N, A, LDA, INFO ) ELSE * * Use blocked code. * IF( UPPER ) THEN * * Compute the Cholesky factorization A = U'*U. * DO 10 J = 1, N, NB * * Update and factorize the current diagonal block and test * for non-positive-definiteness. * JB = MIN( NB, N-J+1 ) CALL ZHERK( '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 * * Compute the current block row. * CALL ZGEMM( '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 ZTRSM( '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 * ELSE * * Compute the Cholesky factorization A = L*L'. * DO 20 J = 1, N, NB * * Update and factorize the current diagonal block and test * for non-positive-definiteness. * JB = MIN( NB, N-J+1 ) CALL ZHERK( '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 * * Compute the current block column. * CALL ZGEMM( '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 ZTRSM( '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 * 30 CONTINUE INFO = INFO + J - 1 * 40 CONTINUE RETURN * * End of ZPOTRF * END SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) * * -- LAPACK auxiliary routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INCX, INCY, N DOUBLE PRECISION C COMPLEX*16 S * .. * .. Array Arguments .. COMPLEX*16 CX( * ), CY( * ) * .. * * Purpose * ======= * * ZROT applies a plane rotation, where the cos (C) is real and the * sin (S) is complex, and the vectors CX and CY are complex. * * Arguments * ========= * * N (input) INTEGER * The number of elements in the vectors CX and CY. * * CX (input/output) COMPLEX*16 array, dimension (N) * On input, the vector X. * On output, CX is overwritten with C*X + S*Y. * * INCX (input) INTEGER * The increment between successive values of CY. INCX <> 0. * * CY (input/output) COMPLEX*16 array, dimension (N) * On input, the vector Y. * On output, CY is overwritten with -CONJG(S)*X + C*Y. * * INCY (input) INTEGER * The increment between successive values of CY. INCX <> 0. * * C (input) DOUBLE PRECISION * S (input) COMPLEX*16 * C and S define a rotation * [ C S ] * [ -conjg(S) C ] * where C*C + S*CONJG(S) = 1.0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IX, IY COMPLEX*16 STEMP * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * IF( N.LE.0 ) $ RETURN IF( INCX.EQ.1 .AND. INCY.EQ.1 ) $ GO TO 20 * * Code for unequal increments or equal increments not equal to 1 * IX = 1 IY = 1 IF( INCX.LT.0 ) $ IX = ( -N+1 )*INCX + 1 IF( INCY.LT.0 ) $ IY = ( -N+1 )*INCY + 1 DO 10 I = 1, N STEMP = C*CX( IX ) + S*CY( IY ) CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX ) CX( IX ) = STEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * * Code for both increments equal to 1 * 20 CONTINUE DO 30 I = 1, N STEMP = C*CX( I ) + S*CY( I ) CY( I ) = C*CY( I ) - DCONJG( S )*CX( I ) CX( I ) = STEMP 30 CONTINUE RETURN END SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER COMPZ INTEGER INFO, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ) COMPLEX*16 Z( LDZ, * ) * .. * * Purpose * ======= * * ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a * symmetric tridiagonal matrix using the implicit QL or QR method. * The eigenvectors of a full or band complex Hermitian matrix can also * be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this * matrix to tridiagonal form. * * Arguments * ========= * * COMPZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only. * = 'V': Compute eigenvalues and eigenvectors of the original * Hermitian matrix. On entry, Z must contain the * unitary matrix used to reduce the original matrix * to tridiagonal form. * = 'I': Compute eigenvalues and eigenvectors of the * tridiagonal matrix. Z is initialized to the identity * matrix. * * N (input) INTEGER * The order of the matrix. N >= 0. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the diagonal elements of the tridiagonal matrix. * On exit, if INFO = 0, the eigenvalues in ascending order. * * E (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, the (n-1) subdiagonal elements of the tridiagonal * matrix. * On exit, E has been destroyed. * * Z (input/output) COMPLEX*16 array, dimension (LDZ, N) * On entry, if COMPZ = 'V', then Z contains the unitary * matrix used in the reduction to tridiagonal form. * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the * orthonormal eigenvectors of the original Hermitian matrix, * and if COMPZ = 'I', Z contains the orthonormal eigenvectors * of the symmetric tridiagonal matrix. * If COMPZ = 'N', then Z is not referenced. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1, and if * eigenvectors are desired, then LDZ >= max(1,N). * * WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) * If COMPZ = 'N', then WORK is not referenced. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: the algorithm has failed to find all the eigenvalues in * a total of 30*N iterations; if INFO = i, then i * elements of E have not converged to zero; on exit, D * and E contain the elements of a symmetric tridiagonal * matrix which is unitarily similar to the original * matrix. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) * .. * .. Local Scalars .. INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, $ NM1, NMAXIT DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 * .. * .. External Subroutines .. EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA, $ ZLASET, ZLASR, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, $ N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZSTEQR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ICOMPZ.EQ.2 ) $ Z( 1, 1 ) = CONE RETURN END IF * * Determine the unit roundoff and over/underflow thresholds. * EPS = DLAMCH( 'E' ) EPS2 = EPS**2 SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN SSFMAX = SQRT( SAFMAX ) / THREE SSFMIN = SQRT( SAFMIN ) / EPS2 * * Compute the eigenvalues and eigenvectors of the tridiagonal * matrix. * IF( ICOMPZ.EQ.2 ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) * NMAXIT = N*MAXIT JTOT = 0 * * Determine where the matrix splits and choose QL or QR iteration * for each block, according to whether top or bottom diagonal * element is smaller. * L1 = 1 NM1 = N - 1 * 10 CONTINUE IF( L1.GT.N ) $ GO TO 160 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO IF( L1.LE.NM1 ) THEN DO 20 M = L1, NM1 TST = ABS( E( M ) ) IF( TST.EQ.ZERO ) $ GO TO 30 IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ $ 1 ) ) ) )*EPS ) THEN E( M ) = ZERO GO TO 30 END IF 20 CONTINUE END IF M = N * 30 CONTINUE L = L1 LSV = L LEND = M LENDSV = LEND L1 = M + 1 IF( LEND.EQ.L ) $ GO TO 10 * * Scale submatrix in rows and columns L to LEND * ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) $ GO TO 10 IF( ANORM.GT.SSFMAX ) THEN ISCALE = 1 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, $ INFO ) ELSE IF( ANORM.LT.SSFMIN ) THEN ISCALE = 2 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, $ INFO ) END IF * * Choose between QL and QR iteration * IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN LEND = LSV L = LENDSV END IF * IF( LEND.GT.L ) THEN * * QL Iteration * * Look for small subdiagonal element. * 40 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 50 M = L, LENDM1 TST = ABS( E( M ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ $ SAFMIN )GO TO 60 50 CONTINUE END IF * M = LEND * 60 CONTINUE IF( M.LT.LEND ) $ E( M ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 80 * * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L+1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) WORK( L ) = C WORK( N-1+L ) = S CALL 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 * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L+1 )-P ) / ( TWO*E( L ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * MM1 = M - 1 DO 70 I = MM1, L, -1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M-1 ) $ E( I+1 ) = R G = D( I+1 ) - P R = ( D( I )-G )*S + TWO*C*B P = S*R D( I+1 ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = -S END IF * 70 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = M - L + 1 CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), $ Z( 1, L ), LDZ ) END IF * D( L ) = D( L ) - P E( L ) = G GO TO 40 * * Eigenvalue found. * 80 CONTINUE D( L ) = P * L = L + 1 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 * ELSE * * QR Iteration * * Look for small superdiagonal element. * 90 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 100 M = L, LENDP1, -1 TST = ABS( E( M-1 ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ $ SAFMIN )GO TO 110 100 CONTINUE END IF * M = LEND * 110 CONTINUE IF( M.GT.LEND ) $ E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 130 * * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L-1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) WORK( M ) = C WORK( N-1+M ) = S CALL 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 * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * LM1 = L - 1 DO 120 I = M, LM1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M ) $ E( I-1 ) = R G = D( I ) - P R = ( D( I+1 )-G )*S + TWO*C*B P = S*R D( I ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = S END IF * 120 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = L - M + 1 CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), $ Z( 1, M ), LDZ ) END IF * D( L ) = D( L ) - P E( LM1 ) = G GO TO 90 * * Eigenvalue found. * 130 CONTINUE D( L ) = P * L = L - 1 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 * END IF * * Undo scaling if necessary * 140 CONTINUE IF( ISCALE.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) ELSE IF( ISCALE.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) END IF * * Check for no convergence to an eigenvalue after a total * of N*MAXIT iterations. * IF( JTOT.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 * * Order eigenvalues and eigenvectors. * 160 CONTINUE IF( ICOMPZ.EQ.0 ) THEN * * Use Quick Sort * CALL DLASRT( 'I', N, D, INFO ) * ELSE * * Use Selection Sort to minimize swaps of eigenvectors * DO 180 II = 2, N I = II - 1 K = I P = D( I ) DO 170 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 170 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 180 CONTINUE END IF RETURN * * End of ZSTEQR * END SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ RWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER INFO, LDA, N DOUBLE PRECISION RCOND * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ) COMPLEX*16 A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * ZTRCON estimates the reciprocal of the condition number of a * triangular matrix A, in either the 1-norm or the infinity-norm. * * The norm of A is computed and an estimate is obtained for * norm(inv(A)), then the reciprocal of the condition number is * computed as * RCOND = 1 / ( norm(A) * norm(inv(A)) ). * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies whether the 1-norm condition number or the * infinity-norm condition number is required: * = '1' or 'O': 1-norm; * = 'I': Infinity-norm. * * UPLO (input) CHARACTER*1 * = 'U': A is upper triangular; * = 'L': A is lower triangular. * * DIAG (input) CHARACTER*1 * = 'N': A is non-unit triangular; * = 'U': A is unit triangular. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The triangular matrix A. If UPLO = 'U', the leading N-by-N * upper triangular part of the array A contains the upper * triangular matrix, and the strictly lower triangular part of * A is not referenced. If UPLO = 'L', the leading N-by-N lower * triangular part of the array A contains the lower triangular * matrix, and the strictly upper triangular part of A is not * referenced. If DIAG = 'U', the diagonal elements of A are * also not referenced and are assumed to be 1. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * RCOND (output) DOUBLE PRECISION * The reciprocal of the condition number of the matrix A, * computed as RCOND = 1/(norm(A) * norm(inv(A))). * * WORK (workspace) COMPLEX*16 array, dimension (2*N) * * RWORK (workspace) DOUBLE PRECISION array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, ONENRM, UPPER CHARACTER NORMIN INTEGER IX, KASE, KASE1 DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM COMPLEX*16 ZDUM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH, ZLANTR EXTERNAL LSAME, IZAMAX, DLAMCH, ZLANTR * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) NOUNIT = LSAME( DIAG, 'N' ) * IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTRCON', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN RCOND = ONE RETURN END IF * RCOND = ZERO SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) ) * * Compute the norm of the triangular matrix A. * ANORM = ZLANTR( NORM, UPLO, DIAG, N, N, A, LDA, RWORK ) * * Continue only if ANORM > 0. * IF( ANORM.GT.ZERO ) THEN * * Estimate the norm of the inverse of A. * AINVNM = ZERO NORMIN = 'N' IF( ONENRM ) THEN KASE1 = 1 ELSE KASE1 = 2 END IF KASE = 0 10 CONTINUE CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * * Multiply by inv(A). * CALL ZLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A, $ LDA, WORK, SCALE, RWORK, INFO ) ELSE * * Multiply by inv(A'). * CALL ZLATRS( UPLO, 'Conjugate transpose', DIAG, NORMIN, $ N, A, LDA, WORK, SCALE, RWORK, INFO ) END IF NORMIN = 'Y' * * Multiply by 1/SCALE if doing so will not cause overflow. * IF( SCALE.NE.ONE ) THEN IX = IZAMAX( N, WORK, 1 ) XNORM = CABS1( WORK( IX ) ) IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO ) $ GO TO 20 CALL ZDRSCL( N, SCALE, WORK, 1 ) END IF GO TO 10 END IF * * Compute the estimate of the reciprocal condition number. * IF( AINVNM.NE.ZERO ) $ RCOND = ( ONE / ANORM ) / AINVNM END IF * 20 CONTINUE RETURN * * End of ZTRCON * END SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) DOUBLE PRECISION RWORK( * ) COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), $ WORK( * ) * .. * * Purpose * ======= * * ZTREVC computes some or all of the right and/or left eigenvectors of * a complex upper triangular matrix T. * Matrices of this type are produced by the Schur factorization of * a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR. * * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: * * T*x = w*x, (y**H)*T = w*(y**H) * * where y**H denotes the conjugate transpose of the vector y. * The eigenvalues are not input to this routine, but are read directly * from the diagonal of T. * * This routine returns the matrices X and/or Y of right and left * eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an * input matrix. If Q is the unitary factor that reduces a matrix A to * Schur form T, then Q*X and Q*Y are the matrices of right and left * eigenvectors of A. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'R': compute right eigenvectors only; * = 'L': compute left eigenvectors only; * = 'B': compute both right and left eigenvectors. * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, * backtransformed using the matrices supplied in * VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * as indicated by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. * The eigenvector corresponding to the j-th eigenvalue is * computed if SELECT(j) = .TRUE.. * Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) COMPLEX*16 array, dimension (LDT,N) * The upper triangular matrix T. T is modified, but restored * on exit. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the unitary matrix Q of * Schur vectors returned by ZHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VL, in the same order as their * eigenvalues. * Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER * The leading dimension of the array VL. LDVL >= 1, and if * SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must * contain an N-by-N matrix Q (usually the unitary matrix Q of * Schur vectors returned by ZHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VR, in the same order as their * eigenvalues. * Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER * The leading dimension of the array VR. LDVR >= 1, and if * SIDE = 'R' or 'B'; LDVR >= N. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. * * M (output) INTEGER * The number of columns in the arrays VL and/or VR actually * used to store the eigenvectors. If HOWMNY = 'A' or 'B', M * is set to N. Each selected eigenvector occupies one * column. * * WORK (workspace) COMPLEX*16 array, dimension (2*N) * * RWORK (workspace) DOUBLE PRECISION array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The algorithm used in this program is basically backward (forward) * substitution, with scaling to make the the code robust against * possible overflow. * * Each eigenvector is normalized so that the element of largest * magnitude has magnitude 1; here the magnitude of a complex number * (x,y) is taken to be |x| + |y|. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) COMPLEX*16 CMZERO, CMONE PARAMETER ( CMZERO = ( 0.0D+0, 0.0D+0 ), $ CMONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV INTEGER I, II, IS, J, K, KI DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL COMPLEX*16 CDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH, DZASUM EXTERNAL LSAME, IZAMAX, DLAMCH, DZASUM * .. * .. External Subroutines .. EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * * Decode and test the input parameters * BOTHV = LSAME( SIDE, 'B' ) RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV * ALLV = LSAME( HOWMNY, 'A' ) OVER = LSAME( HOWMNY, 'B' ) SOMEV = LSAME( HOWMNY, 'S' ) * * Set M to the number of columns required to store the selected * eigenvectors. * IF( SOMEV ) THEN M = 0 DO 10 J = 1, N IF( SELECT( J ) ) $ M = M + 1 10 CONTINUE ELSE M = N END IF * INFO = 0 IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -1 ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN INFO = -8 ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN INFO = -10 ELSE IF( MM.LT.M ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTREVC', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * Set the constants to control overflow. * UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( N / ULP ) * * Store the diagonal elements of T in working array WORK. * DO 20 I = 1, N WORK( I+N ) = T( I, I ) 20 CONTINUE * * Compute 1-norm of each column of strictly upper triangular * part of T to control overflow in triangular solver. * RWORK( 1 ) = ZERO DO 30 J = 2, N RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 ) 30 CONTINUE * IF( RIGHTV ) THEN * * Compute right eigenvectors. * IS = M DO 80 KI = N, 1, -1 * IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 80 END IF SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) * WORK( 1 ) = CMONE * * Form right-hand side. * DO 40 K = 1, KI - 1 WORK( K ) = -T( K, KI ) 40 CONTINUE * * Solve the triangular system: * (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. * DO 50 K = 1, KI - 1 T( K, K ) = T( K, K ) - T( KI, KI ) IF( CABS1( T( K, K ) ).LT.SMIN ) $ T( K, K ) = SMIN 50 CONTINUE * IF( KI.GT.1 ) THEN CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y', $ KI-1, T, LDT, WORK( 1 ), SCALE, RWORK, $ INFO ) WORK( KI ) = SCALE END IF * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL ZCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 ) * II = IZAMAX( KI, VR( 1, IS ), 1 ) REMAX = ONE / CABS1( VR( II, IS ) ) CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 60 K = KI + 1, N VR( K, IS ) = CMZERO 60 CONTINUE ELSE IF( KI.GT.1 ) $ CALL ZGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ), $ 1, DCMPLX( SCALE ), VR( 1, KI ), 1 ) * II = IZAMAX( N, VR( 1, KI ), 1 ) REMAX = ONE / CABS1( VR( II, KI ) ) CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF * * Set back the original diagonal elements of T. * DO 70 K = 1, KI - 1 T( K, K ) = WORK( K+N ) 70 CONTINUE * IS = IS - 1 80 CONTINUE END IF * IF( LEFTV ) THEN * * Compute left eigenvectors. * IS = 1 DO 130 KI = 1, N * IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 130 END IF SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) * WORK( N ) = CMONE * * Form right-hand side. * DO 90 K = KI + 1, N WORK( K ) = -DCONJG( T( KI, K ) ) 90 CONTINUE * * Solve the triangular system: * (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. * DO 100 K = KI + 1, N T( K, K ) = T( K, K ) - T( KI, KI ) IF( CABS1( T( K, K ) ).LT.SMIN ) $ T( K, K ) = SMIN 100 CONTINUE * IF( KI.LT.N ) THEN CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', $ 'Y', N-KI, T( KI+1, KI+1 ), LDT, $ WORK( KI+1 ), SCALE, RWORK, INFO ) WORK( KI ) = SCALE END IF * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL ZCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 ) * II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 REMAX = ONE / CABS1( VL( II, IS ) ) CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) * DO 110 K = 1, KI - 1 VL( K, IS ) = CMZERO 110 CONTINUE ELSE IF( KI.LT.N ) $ CALL ZGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL, $ WORK( KI+1 ), 1, DCMPLX( SCALE ), $ VL( 1, KI ), 1 ) * II = IZAMAX( N, VL( 1, KI ), 1 ) REMAX = ONE / CABS1( VL( II, KI ) ) CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 ) END IF * * Set back the original diagonal elements of T. * DO 120 K = KI + 1, N T( K, K ) = WORK( K+N ) 120 CONTINUE * IS = IS + 1 130 CONTINUE END IF * RETURN * * End of ZTREVC * END SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. COMPLEX*16 Q( LDQ, * ), T( LDT, * ) * .. * * Purpose * ======= * * ZTREXC reorders the Schur factorization of a complex matrix * A = Q*T*Q**H, so that the diagonal element of T with row index IFST * is moved to row ILST. * * The Schur form T is reordered by a unitary similarity transformation * Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by * postmultplying it with Z. * * Arguments * ========= * * COMPQ (input) CHARACTER*1 * = 'V': update the matrix Q of Schur vectors; * = 'N': do not update Q. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) COMPLEX*16 array, dimension (LDT,N) * On entry, the upper triangular matrix T. * On exit, the reordered upper triangular matrix. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * Q (input/output) COMPLEX*16 array, dimension (LDQ,N) * On entry, if COMPQ = 'V', the matrix Q of Schur vectors. * On exit, if COMPQ = 'V', Q has been postmultiplied by the * unitary transformation matrix Z which reorders T. * If COMPQ = 'N', Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= max(1,N). * * IFST (input) INTEGER * ILST (input) INTEGER * Specify the reordering of the diagonal elements of T: * The element with row index IFST is moved to row ILST by a * sequence of transpositions between adjacent elements. * 1 <= IFST <= N; 1 <= ILST <= N. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. LOGICAL WANTQ INTEGER K, M1, M2, M3 DOUBLE PRECISION CS COMPLEX*16 SN, T11, T22, TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARTG, ZROT * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Decode and test the input parameters. * INFO = 0 WANTQ = LSAME( COMPQ, 'V' ) IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -6 ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN INFO = -7 ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTREXC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.1 .OR. IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Move the IFST-th diagonal element forward down the diagonal. * M1 = 0 M2 = -1 M3 = 1 ELSE * * Move the IFST-th diagonal element backward up the diagonal. * M1 = -1 M2 = 0 M3 = -1 END IF * DO 10 K = IFST + M1, ILST + M2, M3 * * Interchange the k-th and (k+1)-th diagonal elements. * T11 = T( K, K ) T22 = T( K+1, K+1 ) * * Determine the transformation to perform the interchange. * CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP ) * * Apply transformation to the matrix T. * IF( K+2.LE.N ) $ CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS, $ SN ) CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS, $ DCONJG( SN ) ) * T( K, K ) = T22 T( K+1, K+1 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS, $ DCONJG( SN ) ) END IF * 10 CONTINUE * RETURN * * End of ZTREXC * END SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZTRTRS solves a triangular system of the form * * A * X = B, A**T * X = B, or A**H * X = B, * * where A is a triangular matrix of order N, and B is an N-by-NRHS * matrix. A check is made to verify that A is nonsingular. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': A is upper triangular; * = 'L': A is lower triangular. * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations: * = 'N': A * X = B (No transpose) * = 'T': A**T * X = B (Transpose) * = 'C': A**H * X = B (Conjugate transpose) * * DIAG (input) CHARACTER*1 * = 'N': A is non-unit triangular; * = 'U': A is unit triangular. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The triangular matrix A. If UPLO = 'U', the leading N-by-N * upper triangular part of the array A contains the upper * triangular matrix, and the strictly lower triangular part of * A is not referenced. If UPLO = 'L', the leading N-by-N lower * triangular part of the array A contains the lower triangular * matrix, and the strictly upper triangular part of A is not * referenced. If DIAG = 'U', the diagonal elements of A are * also not referenced and are assumed to be 1. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, if INFO = 0, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, the i-th diagonal element of A is zero, * indicating that the matrix is singular and the solutions * X have not been computed. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL NOUNIT * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZTRSM * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTRTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Check for singularity. * IF( NOUNIT ) THEN DO 10 INFO = 1, N IF( A( INFO, INFO ).EQ.ZERO ) $ RETURN 10 CONTINUE END IF INFO = 0 * * Solve A * x = b, A**T * x = b, or A**H * x = b. * CALL ZTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B, $ LDB ) * RETURN * * End of ZTRTRS * END SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNG2L generates an m by n complex matrix Q with orthonormal columns, * which is defined as the last n columns of a product of k elementary * reflectors of order m * * Q = H(k) . . . H(2) H(1) * * as returned by ZGEQLF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. M >= N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. N >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the (n-k+i)-th column must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by ZGEQLF in the last k columns of its array * argument A. * On exit, the m-by-n matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQLF. * * WORK (workspace) COMPLEX*16 array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, II, J, L * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNG2L', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Initialise columns 1:n-k to columns of the unit matrix * DO 20 J = 1, N - K DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( M-N+J, J ) = ONE 20 CONTINUE * DO 40 I = 1, K II = N - K + I * * Apply H(i) to A(1:m-k+i,1:n-k+i) from the left * A( M-N+II, II ) = ONE CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, $ LDA, WORK ) CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) A( M-N+II, II ) = ONE - TAU( I ) * * Set A(m-k+i+1:m,n-k+i) to zero * DO 30 L = M - N + II + 1, M A( L, II ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of ZUNG2L * END SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNG2R generates an m by n complex matrix Q with orthonormal columns, * which is defined as the first n columns of a product of k elementary * reflectors of order m * * Q = H(1) H(2) . . . H(k) * * as returned by ZGEQRF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. M >= N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. N >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the i-th column must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by ZGEQRF in the first k columns of its array * argument A. * On exit, the m by n matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQRF. * * WORK (workspace) COMPLEX*16 array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, J, L * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNG2R', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Initialise columns k+1:n to columns of the unit matrix * DO 20 J = K + 1, N DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( J, J ) = ONE 20 CONTINUE * DO 40 I = K, 1, -1 * * Apply H(i) to A(i:m,i:n) from the left * IF( I.LT.N ) THEN A( I, I ) = ONE CALL 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 ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) A( I, I ) = ONE - TAU( I ) * * Set A(1:i-1,i) to zero * DO 30 L = 1, I - 1 A( L, I ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of ZUNG2R * END SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER VECT INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGBR generates one of the complex unitary matrices Q or P**H * determined by ZGEBRD when reducing a complex matrix A to bidiagonal * form: A = Q * B * P**H. Q and P**H are defined as products of * elementary reflectors H(i) or G(i) respectively. * * If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q * is of order M: * if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n * columns of Q, where m >= n >= k; * if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an * M-by-M matrix. * * If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H * is of order N: * if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m * rows of P**H, where n >= m >= k; * if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as * an N-by-N matrix. * * Arguments * ========= * * VECT (input) CHARACTER*1 * Specifies whether the matrix Q or the matrix P**H is * required, as defined in the transformation applied by ZGEBRD: * = 'Q': generate Q; * = 'P': generate P**H. * * M (input) INTEGER * The number of rows of the matrix Q or P**H to be returned. * M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q or P**H to be returned. * N >= 0. * If VECT = 'Q', M >= N >= min(M,K); * if VECT = 'P', N >= M >= min(N,K). * * K (input) INTEGER * If VECT = 'Q', the number of columns in the original M-by-K * matrix reduced by ZGEBRD. * If VECT = 'P', the number of rows in the original K-by-N * matrix reduced by ZGEBRD. * K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the vectors which define the elementary reflectors, * as returned by ZGEBRD. * On exit, the M-by-N matrix Q or P**H. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= M. * * TAU (input) COMPLEX*16 array, dimension * (min(M,K)) if VECT = 'Q' * (min(N,K)) if VECT = 'P' * TAU(i) must contain the scalar factor of the elementary * reflector H(i) or G(i), which determines Q or P**H, as * returned by ZGEBRD in its array argument TAUQ or TAUP. * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,min(M,N)). * For optimum performance LWORK >= min(M,N)*NB, where NB * is the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY, WANTQ INTEGER I, IINFO, J, LWKOPT, MN, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNGLQ, ZUNGQR * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 WANTQ = LSAME( VECT, 'Q' ) MN = MIN( M, N ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. $ MIN( N, K ) ) ) ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN INFO = -9 END IF * IF( INFO.EQ.0 ) THEN IF( WANTQ ) THEN NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) ELSE NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 ) END IF LWKOPT = MAX( 1, MN )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( WANTQ ) THEN * * Form Q, determined by a call to ZGEBRD to reduce an m-by-k * matrix * IF( M.GE.K ) THEN * * If m >= k, assume m >= n >= k * CALL ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) * ELSE * * If m < k, assume m = n * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first row and column of Q * to those of the unit matrix * DO 20 J = M, 2, -1 A( 1, J ) = ZERO DO 10 I = J + 1, M A( I, J ) = A( I, J-1 ) 10 CONTINUE 20 CONTINUE A( 1, 1 ) = ONE DO 30 I = 2, M A( I, 1 ) = ZERO 30 CONTINUE IF( M.GT.1 ) THEN * * Form Q(2:m,2:m) * CALL ZUNGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, $ LWORK, IINFO ) END IF END IF ELSE * * Form P', determined by a call to ZGEBRD to reduce a k-by-n * matrix * IF( K.LT.N ) THEN * * If k < n, assume k <= m <= n * CALL ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) * ELSE * * If k >= n, assume m = n * * Shift the vectors which define the elementary reflectors one * row downward, and set the first row and column of P' to * those of the unit matrix * A( 1, 1 ) = ONE DO 40 I = 2, N A( I, 1 ) = ZERO 40 CONTINUE DO 60 J = 2, N DO 50 I = J - 1, 2, -1 A( I, J ) = A( I-1, J ) 50 CONTINUE A( 1, J ) = ZERO 60 CONTINUE IF( N.GT.1 ) THEN * * Form P'(2:n,2:n) * CALL ZUNGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, $ LWORK, IINFO ) END IF END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNGBR * END SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGHR generates a complex unitary matrix Q which is defined as the * product of IHI-ILO elementary reflectors of order N, as returned by * ZGEHRD: * * Q = H(ilo) H(ilo+1) . . . H(ihi-1). * * Arguments * ========= * * N (input) INTEGER * The order of the matrix Q. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * ILO and IHI must have the same values as in the previous call * of ZGEHRD. Q is equal to the unit matrix except in the * submatrix Q(ilo+1:ihi,ilo+1:ihi). * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the vectors which define the elementary reflectors, * as returned by ZGEHRD. * On exit, the N-by-N unitary matrix Q. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * TAU (input) COMPLEX*16 array, dimension (N-1) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEHRD. * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= IHI-ILO. * For optimum performance LWORK >= (IHI-ILO)*NB, where NB is * the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LWKOPT, NB, NH * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNGQR * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NH = IHI - ILO LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'ZUNGQR', ' ', NH, NH, NH, -1 ) LWKOPT = MAX( 1, NH )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGHR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first ilo and the last n-ihi * rows and columns to those of the unit matrix * DO 40 J = IHI, ILO + 1, -1 DO 10 I = 1, J - 1 A( I, J ) = ZERO 10 CONTINUE DO 20 I = J + 1, IHI A( I, J ) = A( I, J-1 ) 20 CONTINUE DO 30 I = IHI + 1, N A( I, J ) = ZERO 30 CONTINUE 40 CONTINUE DO 60 J = 1, ILO DO 50 I = 1, N A( I, J ) = ZERO 50 CONTINUE A( J, J ) = ONE 60 CONTINUE DO 80 J = IHI + 1, N DO 70 I = 1, N A( I, J ) = ZERO 70 CONTINUE A( J, J ) = ONE 80 CONTINUE * IF( NH.GT.0 ) THEN * * Generate Q(ilo+1:ihi,ilo+1:ihi) * CALL ZUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), $ WORK, LWORK, IINFO ) END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNGHR * END SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, * which is defined as the first m rows of a product of k elementary * reflectors of order n * * Q = H(k)' . . . H(2)' H(1)' * * as returned by ZGELQF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. N >= M. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. M >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the i-th row must contain the vector which defines * the elementary reflector H(i), for i = 1,2,...,k, as returned * by ZGELQF in the first k rows of its array argument A. * On exit, the m by n matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGELQF. * * WORK (workspace) COMPLEX*16 array, dimension (M) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, J, L * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGL2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) $ RETURN * IF( K.LT.M ) THEN * * Initialise rows k+1:m to rows of the unit matrix * DO 20 J = 1, N DO 10 L = K + 1, M A( L, J ) = ZERO 10 CONTINUE IF( J.GT.K .AND. J.LE.M ) $ A( J, J ) = ONE 20 CONTINUE END IF * DO 40 I = K, 1, -1 * * Apply H(i)' to A(i:m,i:n) from the right * IF( I.LT.N ) THEN 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, $ DCONJG( TAU( I ) ), A( I+1, I ), LDA, WORK ) END IF CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) CALL ZLACGV( N-I, A( I, I+1 ), LDA ) END IF A( I, I ) = ONE - DCONJG( TAU( I ) ) * * Set A(i,1:i-1) to zero * DO 30 L = 1, I - 1 A( I, L ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of ZUNGL2 * END SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows, * which is defined as the first M rows of a product of K elementary * reflectors of order N * * Q = H(k)' . . . H(2)' H(1)' * * as returned by ZGELQF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. N >= M. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. M >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the i-th row must contain the vector which defines * the elementary reflector H(i), for i = 1,2,...,k, as returned * by ZGELQF in the first k rows of its array argument A. * On exit, the M-by-N matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGELQF. * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,M). * For optimum performance LWORK >= M*NB, where NB is * the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit; * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNGL2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, M )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGLQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.LE.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZUNGLQ', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNGLQ', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the last block. * The first kk rows are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * * Set A(kk+1:m,1:kk) to zero. * DO 20 J = 1, KK DO 10 I = KK + 1, M A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the last or only block. * IF( KK.LT.M ) $ CALL ZUNGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, $ TAU( KK+1 ), WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF( I+IB.LE.M ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK, LDWORK ) * * Apply H' to A(i+ib:m,i:n) from the right * CALL 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 * * Apply H' to columns i:n of current block * CALL ZUNGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * * Set columns 1:i-1 of current block to zero * DO 40 J = 1, I - 1 DO 30 L = I, I + IB - 1 A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of ZUNGLQ * END SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns, * which is defined as the last N columns of a product of K elementary * reflectors of order M * * Q = H(k) . . . H(2) H(1) * * as returned by ZGEQLF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. M >= N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. N >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the (n-k+i)-th column must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by ZGEQLF in the last k columns of its array * argument A. * On exit, the M-by-N matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQLF. * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK >= N*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, $ NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2L * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.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.EQ.0 ) THEN IF( N.EQ.0 ) THEN LWKOPT = 1 ELSE NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 ) LWKOPT = N*NB END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGQL', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZUNGQL', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQL', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the first block. * The last kk columns are handled by the block method. * KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) * * Set A(m-kk+1:m,1:n-kk) to zero. * DO 20 J = 1, N - KK DO 10 I = M - KK + 1, M A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the first or only block. * CALL ZUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = K - KK + 1, K, NB IB = MIN( NB, K-I+1 ) IF( N-K+I.GT.1 ) THEN * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL ZLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left * CALL ZLARFB( 'Left', 'No transpose', 'Backward', $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, $ WORK( IB+1 ), LDWORK ) END IF * * Apply H to rows 1:m-k+i+ib-1 of current block * CALL ZUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, $ TAU( I ), WORK, IINFO ) * * Set rows m-k+i+ib:m of current block to zero * DO 40 J = N - K + I, N - K + I + IB - 1 DO 30 L = M - K + I + IB, M A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of ZUNGQL * END SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, * which is defined as the first N columns of a product of K elementary * reflectors of order M * * Q = H(1) H(2) . . . H(k) * * as returned by ZGEQRF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. M >= N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. N >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the i-th column must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by ZGEQRF in the first k columns of its array * argument A. * On exit, the M-by-N matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQRF. * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK >= N*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, N )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the last block. * The first kk columns are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * * Set A(1:kk,kk+1:n) to zero. * DO 20 J = KK + 1, N DO 10 I = 1, KK A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the last or only block. * IF( KK.LT.N ) $ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, $ TAU( KK+1 ), WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i:m,i+ib:n) from the left * CALL 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 * * Apply H to rows i:m of current block * CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * * Set rows 1:i-1 of current block to zero * DO 40 J = I, I + IB - 1 DO 30 L = 1, I - 1 A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of ZUNGQR * END SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGR2 generates an m by n complex matrix Q with orthonormal rows, * which is defined as the last m rows of a product of k elementary * reflectors of order n * * Q = H(1)' H(2)' . . . H(k)' * * as returned by ZGERQF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. N >= M. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. M >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the (m-k+i)-th row must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by ZGERQF in the last k rows of its array argument * A. * On exit, the m-by-n matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGERQF. * * WORK (workspace) COMPLEX*16 array, dimension (M) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, II, J, L * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGR2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) $ RETURN * IF( K.LT.M ) THEN * * Initialise rows 1:m-k to rows of the unit matrix * DO 20 J = 1, N DO 10 L = 1, M - K A( L, J ) = ZERO 10 CONTINUE IF( J.GT.N-M .AND. J.LE.N-K ) $ A( M-N+J, J ) = ONE 20 CONTINUE END IF * DO 40 I = 1, K II = M - K + I * * Apply H(i)' to A(1:m-k+i,1:n-k+i) from the right * CALL ZLACGV( N-M+II-1, A( II, 1 ), LDA ) A( II, N-M+II ) = ONE CALL ZLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, $ DCONJG( TAU( I ) ), A, LDA, WORK ) CALL ZSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA ) CALL ZLACGV( N-M+II-1, A( II, 1 ), LDA ) A( II, N-M+II ) = ONE - DCONJG( TAU( I ) ) * * Set A(m-k+i,n-k+i+1:n) to zero * DO 30 L = N - M + II + 1, N A( II, L ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of ZUNGR2 * END SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGRQ generates an M-by-N complex matrix Q with orthonormal rows, * which is defined as the last M rows of a product of K elementary * reflectors of order N * * Q = H(1)' H(2)' . . . H(k)' * * as returned by ZGERQF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. N >= M. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. M >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the (m-k+i)-th row must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by ZGERQF in the last k rows of its array argument * A. * On exit, the M-by-N matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGERQF. * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,M). * For optimum performance LWORK >= M*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, II, IINFO, IWS, J, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNGR2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF * IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN LWKOPT = 1 ELSE NB = ILAENV( 1, 'ZUNGRQ', ' ', M, N, K, -1 ) LWKOPT = M*NB END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGRQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.LE.0 ) THEN RETURN END IF * NBMIN = 2 NX = 0 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZUNGRQ', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNGRQ', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the first block. * The last kk rows are handled by the block method. * KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) * * Set A(1:m-kk,n-kk+1:n) to zero. * DO 20 J = N - KK + 1, N DO 10 I = 1, M - KK A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the first or only block. * CALL ZUNGR2( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = K - KK + 1, K, NB IB = MIN( NB, K-I+1 ) II = M - K + I IF( II.GT.1 ) THEN * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL ZLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB, $ A( II, 1 ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right * CALL ZLARFB( 'Right', 'Conjugate transpose', 'Backward', $ 'Rowwise', II-1, N-K+I+IB-1, IB, A( II, 1 ), $ LDA, WORK, LDWORK, A, LDA, WORK( IB+1 ), $ LDWORK ) END IF * * Apply H' to columns 1:n-k+i+ib-1 of current block * CALL ZUNGR2( IB, N-K+I+IB-1, IB, A( II, 1 ), LDA, TAU( I ), $ WORK, IINFO ) * * Set columns n-k+i+ib:n of current block to zero * DO 40 L = N - K + I + IB, N DO 30 J = II, II + IB - 1 A( J, L ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of ZUNGRQ * END SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGTR generates a complex unitary matrix Q which is defined as the * product of n-1 elementary reflectors of order N, as returned by * ZHETRD: * * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), * * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A contains elementary reflectors * from ZHETRD; * = 'L': Lower triangle of A contains elementary reflectors * from ZHETRD. * * N (input) INTEGER * The order of the matrix Q. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the vectors which define the elementary reflectors, * as returned by ZHETRD. * On exit, the N-by-N unitary matrix Q. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= N. * * TAU (input) COMPLEX*16 array, dimension (N-1) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZHETRD. * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= N-1. * For optimum performance LWORK >= (N-1)*NB, where NB is * the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER INTEGER I, IINFO, J, LWKOPT, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNGQL, ZUNGQR * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF * IF( INFO.EQ.0 ) THEN IF( UPPER ) THEN NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 ) ELSE NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 ) END IF LWKOPT = MAX( 1, N-1 )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGTR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( UPPER ) THEN * * Q was determined by a call to ZHETRD with UPLO = 'U' * * Shift the vectors which define the elementary reflectors one * column to the left, and set the last row and column of Q to * those of the unit matrix * DO 20 J = 1, N - 1 DO 10 I = 1, J - 1 A( I, J ) = A( I, J+1 ) 10 CONTINUE A( N, J ) = ZERO 20 CONTINUE DO 30 I = 1, N - 1 A( I, N ) = ZERO 30 CONTINUE A( N, N ) = ONE * * Generate Q(1:n-1,1:n-1) * CALL ZUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) * ELSE * * Q was determined by a call to ZHETRD with UPLO = 'L'. * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first row and column of Q to * those of the unit matrix * DO 50 J = N, 2, -1 A( 1, J ) = ZERO DO 40 I = J + 1, N A( I, J ) = A( I, J-1 ) 40 CONTINUE 50 CONTINUE A( 1, 1 ) = ONE DO 60 I = 2, N A( I, 1 ) = ZERO 60 CONTINUE IF( N.GT.1 ) THEN * * Generate Q(2:n,2:n) * CALL ZUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, $ LWORK, IINFO ) END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNGTR * END SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNM2R overwrites the general complex m-by-n matrix C with * * Q * C if SIDE = 'L' and TRANS = 'N', or * * Q'* C if SIDE = 'L' and TRANS = 'C', or * * C * Q if SIDE = 'R' and TRANS = 'N', or * * C * Q' if SIDE = 'R' and TRANS = 'C', * * where Q is a complex unitary matrix defined as the product of k * elementary reflectors * * Q = H(1) H(2) . . . H(k) * * as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q' from the Left * = 'R': apply Q or Q' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply Q (No transpose) * = 'C': apply Q' (Conjugate transpose) * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * ZGEQRF in the first k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQRF. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the m-by-n matrix C. * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension * (N) if SIDE = 'L', * (M) if SIDE = 'R' * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ COMPLEX*16 AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, '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 ) THEN CALL XERBLA( 'ZUNM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)' is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) or H(i)' is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) or H(i)' * IF( NOTRAN ) THEN TAUI = TAU( I ) ELSE TAUI = DCONJG( 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 of ZUNM2R * END SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C * with * SIDE = 'L' SIDE = 'R' * TRANS = 'N': Q * C C * Q * TRANS = 'C': Q**H * C C * Q**H * * If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C * with * SIDE = 'L' SIDE = 'R' * TRANS = 'N': P * C C * P * TRANS = 'C': P**H * C C * P**H * * Here Q and P**H are the unitary matrices determined by ZGEBRD when * reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q * and P**H are defined as products of elementary reflectors H(i) and * G(i) respectively. * * Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the * order of the unitary matrix Q or P**H that is applied. * * If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: * if nq >= k, Q = H(1) H(2) . . . H(k); * if nq < k, Q = H(1) H(2) . . . H(nq-1). * * If VECT = 'P', A is assumed to have been a K-by-NQ matrix: * if k < nq, P = G(1) G(2) . . . G(k); * if k >= nq, P = G(1) G(2) . . . G(nq-1). * * Arguments * ========= * * VECT (input) CHARACTER*1 * = 'Q': apply Q or Q**H; * = 'P': apply P or P**H. * * SIDE (input) CHARACTER*1 * = 'L': apply Q, Q**H, P or P**H from the Left; * = 'R': apply Q, Q**H, P or P**H from the Right. * * TRANS (input) CHARACTER*1 * = 'N': No transpose, apply Q or P; * = 'C': Conjugate transpose, apply Q**H or P**H. * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * If VECT = 'Q', the number of columns in the original * matrix reduced by ZGEBRD. * If VECT = 'P', the number of rows in the original * matrix reduced by ZGEBRD. * K >= 0. * * A (input) COMPLEX*16 array, dimension * (LDA,min(nq,K)) if VECT = 'Q' * (LDA,nq) if VECT = 'P' * The vectors which define the elementary reflectors H(i) and * G(i), whose products determine the matrices Q and P, as * returned by ZGEBRD. * * LDA (input) INTEGER * The leading dimension of the array A. * If VECT = 'Q', LDA >= max(1,nq); * if VECT = 'P', LDA >= max(1,min(nq,K)). * * TAU (input) COMPLEX*16 array, dimension (min(nq,K)) * TAU(i) must contain the scalar factor of the elementary * reflector H(i) or G(i) which determines Q or P, as returned * by ZGEBRD in the array argument TAUQ or TAUP. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q * or P*C or P**H*C or C*P or C*P**H. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); * if SIDE = 'R', LWORK >= max(1,M); * if N = 0 or M = 0, LWORK >= 1. * For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L', * and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the * optimal blocksize. (NB = 0 if M = 0 or N = 0.) * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNMLQ, ZUNMQR * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 APPLYQ = LSAME( VECT, 'Q' ) LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q or P and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( M.EQ.0 .OR. N.EQ.0 ) THEN NW = 0 END IF IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -2 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, '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 ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( NW.GT.0 ) THEN IF( APPLYQ ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF ELSE IF( LEFT ) THEN NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF END IF LWKOPT = MAX( 1, NW*NB ) ELSE LWKOPT = 1 END IF WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * IF( APPLYQ ) THEN * * Apply Q * IF( NQ.GE.K ) THEN * * Q was determined by a call to ZGEBRD with nq >= k * CALL ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * Q was determined by a call to ZGEBRD with nq < k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF ELSE * * Apply P * IF( NOTRAN ) THEN TRANST = 'C' ELSE TRANST = 'N' END IF IF( NQ.GT.K ) THEN * * P was determined by a call to ZGEBRD with nq > k * CALL ZUNMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * P was determined by a call to ZGEBRD with nq <= k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL ZUNMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNMBR * END SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNML2 overwrites the general complex m-by-n matrix C with * * Q * C if SIDE = 'L' and TRANS = 'N', or * * Q'* C if SIDE = 'L' and TRANS = 'C', or * * C * Q if SIDE = 'R' and TRANS = 'N', or * * C * Q' if SIDE = 'R' and TRANS = 'C', * * where Q is a complex unitary matrix defined as the product of k * elementary reflectors * * Q = H(k)' . . . H(2)' H(1)' * * as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q' from the Left * = 'R': apply Q or Q' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply Q (No transpose) * = 'C': apply Q' (Conjugate transpose) * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) COMPLEX*16 array, dimension * (LDA,M) if SIDE = 'L', * (LDA,N) if SIDE = 'R' * The i-th row must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * ZGELQF in the first k rows of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,K). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGELQF. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the m-by-n matrix C. * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension * (N) if SIDE = 'L', * (M) if SIDE = 'R' * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ COMPLEX*16 AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, '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 ) THEN CALL XERBLA( 'ZUNML2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)' is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) or H(i)' is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) or H(i)' * IF( NOTRAN ) THEN TAUI = DCONJG( 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 of ZUNML2 * END SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNMLQ overwrites the general complex M-by-N matrix C with * * SIDE = 'L' SIDE = 'R' * TRANS = 'N': Q * C C * Q * TRANS = 'C': Q**H * C C * Q**H * * where Q is a complex unitary matrix defined as the product of k * elementary reflectors * * Q = H(k)' . . . H(2)' H(1)' * * as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q**H from the Left; * = 'R': apply Q or Q**H from the Right. * * TRANS (input) CHARACTER*1 * = 'N': No transpose, apply Q; * = 'C': Conjugate transpose, apply Q**H. * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) COMPLEX*16 array, dimension * (LDA,M) if SIDE = 'L', * (LDA,N) if SIDE = 'R' * The i-th row must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * ZGELQF in the first k rows of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,K). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGELQF. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); * if SIDE = 'R', LWORK >= max(1,M). * For optimum performance LWORK >= N*NB if SIDE 'L', and * LWORK >= M*NB if SIDE = 'R', where NB is the optimal * blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. Local Arrays .. COMPLEX*16 T( LDT, NBMAX ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNML2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, '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 ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size. NB may be at most NBMAX, where NBMAX * is used to define the local array T. * NB = MIN( NBMAX, ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMLQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IWS = NW*NB IF( LWORK.LT.IWS ) THEN NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) END IF ELSE IWS = NW END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IF( ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * IF( NOTRAN ) THEN TRANST = 'C' ELSE TRANST = 'N' END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), T, LDT ) IF( LEFT ) THEN * * H or H' is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H' is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H' * CALL 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 ) = LWKOPT RETURN * * End of ZUNMLQ * END SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNMQR overwrites the general complex M-by-N matrix C with * * SIDE = 'L' SIDE = 'R' * TRANS = 'N': Q * C C * Q * TRANS = 'C': Q**H * C C * Q**H * * where Q is a complex unitary matrix defined as the product of k * elementary reflectors * * Q = H(1) H(2) . . . H(k) * * as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q**H from the Left; * = 'R': apply Q or Q**H from the Right. * * TRANS (input) CHARACTER*1 * = 'N': No transpose, apply Q; * = 'C': Conjugate transpose, apply Q**H. * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * ZGEQRF in the first k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQRF. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); * if SIDE = 'R', LWORK >= max(1,M). * For optimum performance LWORK >= N*NB if SIDE = 'L', and * LWORK >= M*NB if SIDE = 'R', where NB is the optimal * blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. Local Arrays .. COMPLEX*16 T( LDT, NBMAX ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, '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 ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size. NB may be at most NBMAX, where NBMAX * is used to define the local array T. * NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IWS = NW*NB IF( LWORK.LT.IWS ) THEN NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K, $ -1 ) ) END IF ELSE IWS = NW END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), T, LDT ) IF( LEFT ) THEN * * H or H' is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H' is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H' * CALL 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 ) = LWKOPT RETURN * * End of ZUNMQR * END