diff -uNr LAPACK.orig/BLAS/TESTING/cblat2.f LAPACK/BLAS/TESTING/cblat2.f --- LAPACK.orig/BLAS/TESTING/cblat2.f Thu Nov 4 14:23:26 1999 +++ LAPACK/BLAS/TESTING/cblat2.f Fri May 25 15:57:46 2001 @@ -64,6 +64,10 @@ * Richard Hanson, Sandia National Labs. * Jeremy Du Croz, NAG Central Office. * +* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers +* can be run multiple times without deleting generated +* output files (susan) +* * .. Parameters .. INTEGER NIN PARAMETER ( NIN = 5 ) @@ -126,7 +130,7 @@ * READ( NIN, FMT = * )SUMMRY READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' ) + OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) NOUTC = NOUT * * Read name and unit number for snapshot output file and open file. @@ -135,7 +139,7 @@ READ( NIN, FMT = * )NTRA TRACE = NTRA.GE.0 IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) + OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) END IF * Read the flag that directs rewinding of the snapshot file. READ( NIN, FMT = * )REWI diff -uNr LAPACK.orig/BLAS/TESTING/cblat3.f LAPACK/BLAS/TESTING/cblat3.f --- LAPACK.orig/BLAS/TESTING/cblat3.f Thu Nov 4 14:23:26 1999 +++ LAPACK/BLAS/TESTING/cblat3.f Fri May 25 15:58:08 2001 @@ -46,6 +46,10 @@ * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * +* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers +* can be run multiple times without deleting generated +* output files (susan) +* * .. Parameters .. INTEGER NIN PARAMETER ( NIN = 5 ) diff -uNr LAPACK.orig/BLAS/TESTING/dblat2.f LAPACK/BLAS/TESTING/dblat2.f --- LAPACK.orig/BLAS/TESTING/dblat2.f Thu Nov 4 14:23:27 1999 +++ LAPACK/BLAS/TESTING/dblat2.f Fri May 25 15:57:41 2001 @@ -63,6 +63,10 @@ * Richard Hanson, Sandia National Labs. * Jeremy Du Croz, NAG Central Office. * +* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers +* can be run multiple times without deleting generated +* output files (susan) +* * .. Parameters .. INTEGER NIN PARAMETER ( NIN = 5 ) @@ -121,7 +125,7 @@ * READ( NIN, FMT = * )SUMMRY READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' ) + OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) NOUTC = NOUT * * Read name and unit number for snapshot output file and open file. @@ -130,7 +134,7 @@ READ( NIN, FMT = * )NTRA TRACE = NTRA.GE.0 IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) + OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) END IF * Read the flag that directs rewinding of the snapshot file. READ( NIN, FMT = * )REWI diff -uNr LAPACK.orig/BLAS/TESTING/dblat3.f LAPACK/BLAS/TESTING/dblat3.f --- LAPACK.orig/BLAS/TESTING/dblat3.f Thu Nov 4 14:23:27 1999 +++ LAPACK/BLAS/TESTING/dblat3.f Fri May 25 15:58:04 2001 @@ -43,6 +43,10 @@ * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * +* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers +* can be run multiple times without deleting generated +* output files (susan) +* * .. Parameters .. INTEGER NIN PARAMETER ( NIN = 5 ) @@ -96,7 +100,7 @@ * READ( NIN, FMT = * )SUMMRY READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' ) + OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) NOUTC = NOUT * * Read name and unit number for snapshot output file and open file. @@ -105,7 +109,7 @@ READ( NIN, FMT = * )NTRA TRACE = NTRA.GE.0 IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) + OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) END IF * Read the flag that directs rewinding of the snapshot file. READ( NIN, FMT = * )REWI diff -uNr LAPACK.orig/BLAS/TESTING/sblat2.f LAPACK/BLAS/TESTING/sblat2.f --- LAPACK.orig/BLAS/TESTING/sblat2.f Thu Nov 4 14:23:26 1999 +++ LAPACK/BLAS/TESTING/sblat2.f Fri May 25 15:57:34 2001 @@ -63,6 +63,10 @@ * Richard Hanson, Sandia National Labs. * Jeremy Du Croz, NAG Central Office. * +* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers +* can be run multiple times without deleting generated +* output files (susan) +* * .. Parameters .. INTEGER NIN PARAMETER ( NIN = 5 ) @@ -121,7 +125,7 @@ * READ( NIN, FMT = * )SUMMRY READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' ) + OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) NOUTC = NOUT * * Read name and unit number for snapshot output file and open file. @@ -130,7 +134,7 @@ READ( NIN, FMT = * )NTRA TRACE = NTRA.GE.0 IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) + OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) END IF * Read the flag that directs rewinding of the snapshot file. READ( NIN, FMT = * )REWI diff -uNr LAPACK.orig/BLAS/TESTING/sblat3.f LAPACK/BLAS/TESTING/sblat3.f --- LAPACK.orig/BLAS/TESTING/sblat3.f Thu Nov 4 14:23:26 1999 +++ LAPACK/BLAS/TESTING/sblat3.f Fri May 25 15:58:00 2001 @@ -43,6 +43,10 @@ * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * +* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers +* can be run multiple times without deleting generated +* output files (susan) +* * .. Parameters .. INTEGER NIN PARAMETER ( NIN = 5 ) diff -uNr LAPACK.orig/BLAS/TESTING/zblat2.f LAPACK/BLAS/TESTING/zblat2.f --- LAPACK.orig/BLAS/TESTING/zblat2.f Thu Nov 4 14:23:27 1999 +++ LAPACK/BLAS/TESTING/zblat2.f Fri May 25 15:57:52 2001 @@ -64,6 +64,10 @@ * Richard Hanson, Sandia National Labs. * Jeremy Du Croz, NAG Central Office. * +* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers +* can be run multiple times without deleting generated +* output files (susan) +* * .. Parameters .. INTEGER NIN PARAMETER ( NIN = 5 ) @@ -127,7 +131,7 @@ * READ( NIN, FMT = * )SUMMRY READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' ) + OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) NOUTC = NOUT * * Read name and unit number for snapshot output file and open file. @@ -136,7 +140,7 @@ READ( NIN, FMT = * )NTRA TRACE = NTRA.GE.0 IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) + OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) END IF * Read the flag that directs rewinding of the snapshot file. READ( NIN, FMT = * )REWI diff -uNr LAPACK.orig/BLAS/TESTING/zblat3.f LAPACK/BLAS/TESTING/zblat3.f --- LAPACK.orig/BLAS/TESTING/zblat3.f Thu Nov 4 14:23:27 1999 +++ LAPACK/BLAS/TESTING/zblat3.f Fri May 25 15:58:16 2001 @@ -46,6 +46,10 @@ * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * +* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers +* can be run multiple times without deleting generated +* output files (susan) +* * .. Parameters .. INTEGER NIN PARAMETER ( NIN = 5 ) @@ -104,7 +108,7 @@ * READ( NIN, FMT = * )SUMMRY READ( NIN, FMT = * )NOUT - OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' ) + OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) NOUTC = NOUT * * Read name and unit number for snapshot output file and open file. @@ -113,7 +117,7 @@ READ( NIN, FMT = * )NTRA TRACE = NTRA.GE.0 IF( TRACE )THEN - OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) + OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) END IF * Read the flag that directs rewinding of the snapshot file. READ( NIN, FMT = * )REWI @@ -1962,6 +1966,7 @@ * 3-19-92: Initialize ALPHA, BETA, RALPHA, and RBETA (eca) * 3-19-92: Fix argument 12 in calls to ZSYMM and ZHEMM * with INFOT = 9 (eca) +* 10-9-00: Declared INTRINSIC DCMPLX (susan) * * .. Scalar Arguments .. INTEGER ISNUM, NOUT @@ -1980,6 +1985,8 @@ * .. External Subroutines .. EXTERNAL ZGEMM, ZHEMM, ZHER2K, ZHERK, CHKXER, ZSYMM, $ ZSYR2K, ZSYRK, ZTRMM, ZTRSM +* .. Intrinsic Functions .. + INTRINSIC DCMPLX * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Executable Statements .. diff -uNr LAPACK.orig/INSTALL/make.inc.LINUX LAPACK/INSTALL/make.inc.LINUX --- LAPACK.orig/INSTALL/make.inc.LINUX Thu Nov 4 14:23:30 1999 +++ LAPACK/INSTALL/make.inc.LINUX Fri May 25 15:58:36 2001 @@ -17,7 +17,7 @@ # desired load options for your machine. # FORTRAN = g77 -OPTS = -funroll-all-loops -fno-f2c -O3 +OPTS = -funroll-all-loops -O3 DRVOPTS = $(OPTS) NOOPT = LOADER = g77 diff -uNr LAPACK.orig/SRC/cbdsqr.f LAPACK/SRC/cbdsqr.f --- LAPACK.orig/SRC/cbdsqr.f Thu Nov 4 14:23:31 1999 +++ LAPACK/SRC/cbdsqr.f Fri May 25 15:59:05 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. CHARACTER UPLO @@ -18,14 +18,26 @@ * Purpose * ======= * -* CBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. -* -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given complex input matrices U, VT, and C. +* CBDSQR 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 CGEBRD, 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, @@ -61,18 +73,17 @@ * order. * * E (input/output) REAL array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E +* 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. E(N) is used for workspace. * * VT (input/output) COMPLEX array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. +* On exit, VT is overwritten by P**H * VT. +* Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. @@ -81,21 +92,22 @@ * U (input/output) COMPLEX array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. -* U is not referenced if NRU = 0. +* Not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) COMPLEX array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. -* On exit, C is overwritten by Q' * C. -* C is not referenced if NCC = 0. +* 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) REAL array, dimension (4*N) +* RWORK (workspace) REAL array, dimension (2*N) +* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise * * INFO (output) INTEGER * = 0: successful exit diff -uNr LAPACK.orig/SRC/cgebd2.f LAPACK/SRC/cgebd2.f --- LAPACK.orig/SRC/cgebd2.f Thu Nov 4 14:24:07 1999 +++ LAPACK/SRC/cgebd2.f Fri May 25 15:59:27 2001 @@ -3,7 +3,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* May 7, 2001 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -172,8 +172,9 @@ * * Apply H(i)' to A(i:m,i+1:n) from the left * - CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ CONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) + IF( I.LT.N ) + $ CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, + $ CONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN @@ -215,8 +216,9 @@ * * Apply G(i) to A(i+1:m,i:n) from the right * - CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), - $ A( MIN( I+1, M ), I ), LDA, WORK ) + IF( I.LT.M ) + $ CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( MIN( I+1, M ), I ), LDA, WORK ) CALL CLACGV( N-I+1, A( I, I ), LDA ) A( I, I ) = D( I ) * diff -uNr LAPACK.orig/SRC/cgees.f LAPACK/SRC/cgees.f --- LAPACK.orig/SRC/cgees.f Thu Nov 4 14:24:08 1999 +++ LAPACK/SRC/cgees.f Fri May 25 15:59:55 2001 @@ -5,6 +5,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVS, SORT @@ -89,10 +90,9 @@ * 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. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) REAL array, dimension (N) * @@ -120,11 +120,13 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, SCALEA, WANTST, WANTVS + LOGICAL SCALEA, WANTST, WANTVS INTEGER HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO, $ ITAU, IWRK, K, MAXB, MAXWRK, MINWRK REAL ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM @@ -150,7 +152,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) WANTVS = LSAME( JOBVS, 'V' ) WANTST = LSAME( SORT, 'S' ) IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN @@ -177,7 +178,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = N + N*ILAENV( 1, 'CGEHRD', ' ', N, 1, N, 0 ) MINWRK = MAX( 1, 2*N ) IF( .NOT.WANTVS ) THEN @@ -196,19 +197,17 @@ MAXWRK = MAX( MAXWRK, HSWORK, 1 ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -12 END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEES ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/cgeesx.f LAPACK/SRC/cgeesx.f --- LAPACK.orig/SRC/cgeesx.f Thu Nov 4 14:24:08 1999 +++ LAPACK/SRC/cgeesx.f Fri May 25 16:00:18 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Do WS calculations if LWORK = -1 (eca) * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT @@ -119,6 +120,10 @@ * this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. * For good performance, LWORK must generally be larger. * +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. +* * RWORK (workspace) REAL array, dimension (N) * * BWORK (workspace) LOGICAL array, dimension (N) @@ -144,6 +149,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. @@ -211,7 +218,7 @@ * in the code.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = N + N*ILAENV( 1, 'CGEHRD', ' ', N, 1, N, 0 ) MINWRK = MAX( 1, 2*N ) IF( .NOT.WANTVS ) THEN @@ -229,18 +236,24 @@ HSWORK = MAX( K*( K+2 ), 2*N ) MAXWRK = MAX( MAXWRK, HSWORK, 1 ) END IF +* +* Estimate the workspace needed by CTRSEN. +* + IF( WANTST ) THEN + MAXWRK = MAX( MAXWRK, (N*N+1)/2 ) + END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + & INFO = -15 END IF - IF( LWORK.LT.MINWRK ) THEN - INFO = -15 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEESX', -INFO ) RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/cgeev.f LAPACK/SRC/cgeev.f --- LAPACK.orig/SRC/cgeev.f Thu Nov 4 14:24:08 1999 +++ LAPACK/SRC/cgeev.f Fri May 25 16:00:48 2001 @@ -5,6 +5,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -85,10 +86,9 @@ * 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. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) REAL array, dimension (2*N) * @@ -103,11 +103,13 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, SCALEA, WANTVL, WANTVR + LOGICAL SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, $ IWRK, K, MAXB, MAXWRK, MINWRK, NOUT @@ -136,7 +138,6 @@ * 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 @@ -165,7 +166,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = N + N*ILAENV( 1, 'CGEHRD', ' ', N, 1, N, 0 ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = MAX( 1, 2*N ) @@ -185,19 +186,17 @@ MAXWRK = MAX( MAXWRK, HSWORK, 2*N ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -12 END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEEV ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/cgeevx.f LAPACK/SRC/cgeevx.f --- LAPACK.orig/SRC/cgeevx.f Thu Nov 4 14:24:08 1999 +++ LAPACK/SRC/cgeevx.f Fri May 25 16:01:10 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE @@ -166,10 +167,9 @@ * LWORK >= N*N+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. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) REAL array, dimension (2*N) * @@ -184,12 +184,14 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, - $ WNTSNN, WNTSNV + LOGICAL SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, WNTSNN, + $ WNTSNV CHARACTER JOB, SIDE INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXB, $ MAXWRK, MINWRK, NOUT @@ -219,7 +221,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) WANTVL = LSAME( JOBVL, 'V' ) WANTVR = LSAME( JOBVR, 'V' ) WNTSNN = LSAME( SENSE, 'N' ) @@ -259,7 +260,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = N + N*ILAENV( 1, 'CGEHRD', ' ', N, 1, N, 0 ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = MAX( 1, 2*N ) @@ -293,19 +294,17 @@ MAXWRK = MAX( MAXWRK, 2*N, 1 ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -20 END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -20 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGEEVX', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/cgegs.f LAPACK/SRC/cgegs.f --- LAPACK.orig/SRC/cgegs.f Thu Nov 4 14:24:08 1999 +++ LAPACK/SRC/cgegs.f Fri May 25 16:01:59 2001 @@ -5,7 +5,7 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR @@ -23,83 +23,70 @@ * * This routine is deprecated and has been replaced by routine CGGES. * -* CGEGS computes for a pair of N-by-N complex nonsymmetric matrices A, -* B: the generalized eigenvalues (alpha, beta), the complex Schur -* form (A, B), and optionally left and/or right Schur vectors -* (VSL and VSR). -* -* (If only the generalized eigenvalues are needed, use the driver CGEGV -* instead.) -* -* A generalized eigenvalue for a pair of matrices (A,B) is, roughly -* speaking, a scalar w or a ratio alpha/beta = w, such that A - w*B -* is singular. It is usually represented as the pair (alpha,beta), -* as there is a reasonable interpretation for beta=0, and even for -* both being zero. A good beginning reference is the book, "Matrix -* Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press) -* -* The (generalized) Schur form of a pair of matrices is the result of -* multiplying both matrices on the left by one unitary matrix and -* both on the right by another unitary matrix, these two unitary -* matrices being chosen so as to bring the pair of matrices into -* upper triangular form with the diagonal elements of B being -* non-negative real numbers (this is also called complex Schur form.) -* -* The left and right Schur vectors are the columns of VSL and VSR, -* respectively, where VSL and VSR are the unitary matrices -* which reduce A and B to Schur form: -* -* Schur form of (A,B) = ( (VSL)**H A (VSR), (VSL)**H B (VSR) ) +* CGEGS computes the eigenvalues, Schur form, and, optionally, the +* left and or/right Schur vectors of a complex matrix pair (A,B). +* Given two square matrices A and B, the generalized Schur +* factorization has the form +* +* A = Q*S*Z**H, B = Q*T*Z**H +* +* where Q and Z are unitary matrices and S and T are upper triangular. +* The columns of Q are the left Schur vectors +* and the columns of Z are the right Schur vectors. +* +* If only the eigenvalues of (A,B) are needed, the driver routine +* CGEGV should be used instead. See CGEGV for a description of the +* eigenvalues of the generalized nonsymmetric eigenvalue problem +* (GNEP). * * Arguments * ========= * * JOBVSL (input) CHARACTER*1 * = 'N': do not compute the left Schur vectors; -* = 'V': compute the left Schur vectors. +* = 'V': compute the left Schur vectors (returned in VSL). * * JOBVSR (input) CHARACTER*1 * = 'N': do not compute the right Schur vectors; -* = 'V': compute the right Schur vectors. +* = 'V': compute the right Schur vectors (returned in VSR). * * N (input) INTEGER * The order of the matrices A, B, VSL, and VSR. N >= 0. * * A (input/output) COMPLEX array, dimension (LDA, N) -* On entry, the first of the pair of matrices whose generalized -* eigenvalues and (optionally) Schur vectors are to be -* computed. -* On exit, the generalized Schur form of A. +* On entry, the matrix A. +* On exit, the upper triangular matrix S from the generalized +* Schur factorization. * * LDA (input) INTEGER * The leading dimension of A. LDA >= max(1,N). * * B (input/output) COMPLEX array, dimension (LDB, N) -* On entry, the second of the pair of matrices whose -* generalized eigenvalues and (optionally) Schur vectors are -* to be computed. -* On exit, the generalized Schur form of B. +* On entry, the matrix B. +* On exit, the upper triangular matrix T from the generalized +* Schur factorization. * * LDB (input) INTEGER * The leading dimension of B. LDB >= max(1,N). * * ALPHA (output) COMPLEX array, dimension (N) +* The complex scalars alpha that define the eigenvalues of +* GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur +* form of A. +* * BETA (output) COMPLEX array, dimension (N) -* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the -* generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j), -* j=1,...,N are the diagonals of the complex Schur form (A,B) -* output by CGEGS. The BETA(j) will be non-negative real. -* -* Note: the quotients ALPHA(j)/BETA(j) may easily over- or -* underflow, and BETA(j) may even be zero. Thus, the user -* should avoid naively computing the ratio alpha/beta. -* However, ALPHA will be always less than and usually -* comparable with norm(A) in magnitude, and BETA always less -* than and usually comparable with norm(B). +* The non-negative real scalars beta that define the +* eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element +* of the triangular factor T. +* +* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) +* represent the j-th eigenvalue of the matrix pair (A,B), in +* one of the forms lambda = alpha/beta or mu = beta/alpha. +* Since either lambda or mu may overflow, they should not, +* in general, be computed. * * VSL (output) COMPLEX array, dimension (LDVSL,N) -* If JOBVSL = 'V', VSL will contain the left Schur vectors. -* (See "Purpose", above.) +* If JOBVSL = 'V', the matrix of left Schur vectors Q. * Not referenced if JOBVSL = 'N'. * * LDVSL (input) INTEGER @@ -107,8 +94,7 @@ * if JOBVSL = 'V', LDVSL >= N. * * VSR (output) COMPLEX array, dimension (LDVSR,N) -* If JOBVSR = 'V', VSR will contain the right Schur vectors. -* (See "Purpose", above.) +* If JOBVSR = 'V', the matrix of right Schur vectors Z. * Not referenced if JOBVSR = 'N'. * * LDVSR (input) INTEGER diff -uNr LAPACK.orig/SRC/cgegv.f LAPACK/SRC/cgegv.f --- LAPACK.orig/SRC/cgegv.f Thu Nov 4 14:24:08 1999 +++ LAPACK/SRC/cgegv.f Fri May 25 16:02:21 2001 @@ -4,7 +4,7 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -22,22 +22,28 @@ * * This routine is deprecated and has been replaced by routine CGGEV. * -* CGEGV computes for a pair of N-by-N complex nonsymmetric matrices A -* and B, the generalized eigenvalues (alpha, beta), and optionally, -* the left and/or right generalized eigenvectors (VL and VR). -* -* A generalized eigenvalue for a pair of matrices (A,B) is, roughly -* speaking, a scalar w or a ratio alpha/beta = w, such that A - w*B -* is singular. It is usually represented as the pair (alpha,beta), -* as there is a reasonable interpretation for beta=0, and even for -* both being zero. A good beginning reference is the book, "Matrix -* Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press) -* -* A right generalized eigenvector corresponding to a generalized -* eigenvalue w for a pair of matrices (A,B) is a vector r such -* that (A - w B) r = 0 . A left generalized eigenvector is a vector -* l such that l**H * (A - w B) = 0, where l**H is the -* conjugate-transpose of l. +* CGEGV computes the eigenvalues and, optionally, the left and/or right +* eigenvectors of a complex matrix pair (A,B). +* Given two square matrices A and B, +* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the +* eigenvalues lambda and corresponding (non-zero) eigenvectors x such +* that +* A*x = lambda*B*x. +* +* An alternate form is to find the eigenvalues mu and corresponding +* eigenvectors y such that +* mu*A*y = B*y. +* +* These two forms are equivalent with mu = 1/lambda and x = y if +* neither lambda nor mu is zero. In order to deal with the case that +* lambda or mu is zero or small, two values alpha and beta are returned +* for each eigenvalue, such that lambda = alpha/beta and +* mu = beta/alpha. +* +* The vectors x and y in the above equations are right eigenvectors of +* the matrix pair (A,B). Vectors u and v satisfying +* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B +* are left eigenvectors of (A,B). * * Note: this routine performs "full balancing" on A and B -- see * "Further Details", below. @@ -47,56 +53,62 @@ * * JOBVL (input) CHARACTER*1 * = 'N': do not compute the left generalized eigenvectors; -* = 'V': compute the left generalized eigenvectors. +* = 'V': compute the left generalized eigenvectors (returned +* in VL). * * JOBVR (input) CHARACTER*1 * = 'N': do not compute the right generalized eigenvectors; -* = 'V': compute the right generalized eigenvectors. +* = 'V': compute the right generalized eigenvectors (returned +* in VR). * * N (input) INTEGER * The order of the matrices A, B, VL, and VR. N >= 0. * * A (input/output) COMPLEX array, dimension (LDA, N) -* On entry, the first of the pair of matrices whose -* generalized eigenvalues and (optionally) generalized -* eigenvectors are to be computed. -* On exit, the contents will have been destroyed. (For a -* description of the contents of A on exit, see "Further -* Details", below.) +* On entry, the matrix A. +* If JOBVL = 'V' or JOBVR = 'V', then on exit A +* contains the Schur form of A from the generalized Schur +* factorization of the pair (A,B) after balancing. If no +* eigenvectors were computed, then only the diagonal elements +* of the Schur form will be correct. See CGGHRD and CHGEQZ +* for details. * * LDA (input) INTEGER * The leading dimension of A. LDA >= max(1,N). * * B (input/output) COMPLEX array, dimension (LDB, N) -* On entry, the second of the pair of matrices whose -* generalized eigenvalues and (optionally) generalized -* eigenvectors are to be computed. -* On exit, the contents will have been destroyed. (For a -* description of the contents of B on exit, see "Further -* Details", below.) +* On entry, the matrix B. +* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the +* upper triangular matrix obtained from B in the generalized +* Schur factorization of the pair (A,B) after balancing. +* If no eigenvectors were computed, then only the diagonal +* elements of B will be correct. See CGGHRD and CHGEQZ for +* details. * * LDB (input) INTEGER * The leading dimension of B. LDB >= max(1,N). * * ALPHA (output) COMPLEX array, dimension (N) -* BETA (output) COMPLEX array, dimension (N) -* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the -* generalized eigenvalues. +* The complex scalars alpha that define the eigenvalues of +* GNEP. * -* Note: the quotients ALPHA(j)/BETA(j) may easily over- or -* underflow, and BETA(j) may even be zero. Thus, the user -* should avoid naively computing the ratio alpha/beta. -* However, ALPHA will be always less than and usually -* comparable with norm(A) in magnitude, and BETA always less -* than and usually comparable with norm(B). +* BETA (output) COMPLEX array, dimension (N) +* The complex scalars beta that define the eigenvalues of GNEP. +* +* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) +* represent the j-th eigenvalue of the matrix pair (A,B), in +* one of the forms lambda = alpha/beta or mu = beta/alpha. +* Since either lambda or mu may overflow, they should not, +* in general, be computed. + * * VL (output) COMPLEX array, dimension (LDVL,N) -* If JOBVL = 'V', the left generalized eigenvectors. (See -* "Purpose", above.) -* Each eigenvector will be scaled so the largest component -* will have abs(real part) + abs(imag. part) = 1, *except* -* that for eigenvalues with alpha=beta=0, a zero vector will -* be returned as the corresponding eigenvector. +* If JOBVL = 'V', the left eigenvectors u(j) are stored +* in the columns of VL, in the same order as their eigenvalues. +* Each eigenvector is scaled so that its largest component has +* abs(real part) + abs(imag. part) = 1, except for eigenvectors +* corresponding to an eigenvalue with alpha = beta = 0, which +* are set to zero. * Not referenced if JOBVL = 'N'. * * LDVL (input) INTEGER @@ -104,12 +116,12 @@ * if JOBVL = 'V', LDVL >= N. * * VR (output) COMPLEX array, dimension (LDVR,N) -* If JOBVR = 'V', the right generalized eigenvectors. (See -* "Purpose", above.) -* Each eigenvector will be scaled so the largest component -* will have abs(real part) + abs(imag. part) = 1, *except* -* that for eigenvalues with alpha=beta=0, a zero vector will -* be returned as the corresponding eigenvector. +* If JOBVR = 'V', the right eigenvectors x(j) are stored +* in the columns of VR, in the same order as their eigenvalues. +* Each eigenvector is scaled so that its largest component has +* abs(real part) + abs(imag. part) = 1, except for eigenvectors +* corresponding to an eigenvalue with alpha = beta = 0, which +* are set to zero. * Not referenced if JOBVR = 'N'. * * LDVR (input) INTEGER diff -uNr LAPACK.orig/SRC/cgelsd.f LAPACK/SRC/cgelsd.f --- LAPACK.orig/SRC/cgelsd.f Thu Nov 4 14:26:25 1999 +++ LAPACK/SRC/cgelsd.f Fri May 25 16:03:27 2001 @@ -4,7 +4,8 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -64,7 +65,8 @@ * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the M-by-N matrix A. -* On exit, A has been destroyed. +* On exit, the first min(m,n) rows of A are overwritten with +* its right singular vectors, stored rowwise. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). @@ -96,32 +98,24 @@ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER -* The dimension of the array WORK. LWORK must be at least 1. +* The dimension of the array WORK. LWORK >= 1. * The exact minimum amount of workspace needed depends on M, -* N and NRHS. As long as LWORK is at least -* 2 * N + N * NRHS -* if M is greater than or equal to N or -* 2 * M + M * NRHS -* if M is less than N, the code will execute correctly. +* N and NRHS. +* If M >= N, LWORK >= 2*N + N*NRHS. +* If M < N, LWORK >= 2*M + M*NRHS. * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* -* RWORK (workspace) REAL array, dimension at least -* 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + -* (SMLSIZ+1)**2 -* if M is greater than or equal to N or -* 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS + -* (SMLSIZ+1)**2 -* if M is less than N, the code will execute correctly. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. +* +* RWORK (workspace) REAL array, dimension (LRWORK) +* If M >= N, LRWORK >= 8*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS. +* If M < N, LRWORK >= 8*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS. * SMLSIZ is returned by ILAENV and is equal to the maximum * size of the subproblems at the bottom of the computation * tree (usually about 25), and -* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) +* NLVL = INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 * * IWORK (workspace) INTEGER array, dimension (LIWORK) * LIWORK >= 3 * MINMN * NLVL + 11 * MINMN, @@ -145,13 +139,14 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) COMPLEX CZERO PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. - LOGICAL LQUERY INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ, $ LDWORK, MAXMN, MAXWRK, MINMN, MINWRK, MM, $ MNTHR, NRWORK, NWORK, SMLSIZ @@ -179,7 +174,6 @@ MINMN = MIN( M, N ) MAXMN = MAX( M, N ) MNTHR = ILAENV( 6, 'CGELSD', ' ', M, N, NRHS, -1 ) - LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN @@ -263,20 +257,17 @@ END IF MINWRK = MIN( MINWRK, MAXWRK ) WORK( 1 ) = CMPLX( MAXWRK, 0 ) - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -12 END IF * +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGELSD', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - GO TO 10 END IF -* -* Quick return if possible. -* + IF( LWORK.EQ.LQUERV ) RETURN IF( M.EQ.0 .OR. N.EQ.0 ) THEN RANK = 0 RETURN diff -uNr LAPACK.orig/SRC/cgelss.f LAPACK/SRC/cgelss.f --- LAPACK.orig/SRC/cgelss.f Thu Nov 4 14:24:09 1999 +++ LAPACK/SRC/cgelss.f Fri May 25 16:03:50 2001 @@ -4,7 +4,7 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -87,10 +87,9 @@ * LWORK >= 2*min(M,N) + max(M,N,NRHS) * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) REAL array, dimension (5*min(M,N)) * @@ -164,7 +163,7 @@ * immediately following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 0 MM = M IF( M.GE.N .AND. M.GE.MNTHR ) THEN @@ -235,19 +234,18 @@ MINWRK = MAX( MINWRK, 1 ) MAXWRK = MAX( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGELSS', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF -* -* Quick return if possible -* IF( M.EQ.0 .OR. N.EQ.0 ) THEN RANK = 0 RETURN @@ -512,8 +510,8 @@ DO 40 I = 1, NRHS, CHUNK BL = MIN( NRHS-I+1, CHUNK ) CALL CGEMM( 'C', 'N', M, BL, M, CONE, WORK( IL ), LDWORK, - $ B( 1, I ), LDB, CZERO, WORK( IWORK ), N ) - CALL CLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ), + $ B( 1, I ), LDB, CZERO, WORK( IWORK ), M ) + CALL CLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), $ LDB ) 40 CONTINUE ELSE diff -uNr LAPACK.orig/SRC/cgesdd.f LAPACK/SRC/cgesdd.f --- LAPACK.orig/SRC/cgesdd.f Thu Nov 11 20:32:54 1999 +++ LAPACK/SRC/cgesdd.f Fri May 25 16:08:03 2001 @@ -1,10 +1,11 @@ - SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, - $ LWORK, RWORK, IWORK, INFO ) + SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, RWORK, IWORK, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBZ @@ -119,12 +120,14 @@ * if JOBZ = 'S' or 'A', * LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N). * For good performance, LWORK should generally be larger. -* If LWORK < 0 but other input arguments are legal, WORK(1) -* returns the optimal LWORK. +* +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) REAL array, dimension (LRWORK) -* If JOBZ = 'N', LRWORK >= 7*min(M,N). -* Otherwise, LRWORK >= 5*min(M,N)*min(M,N) + 5*min(M,N) +* If JOBZ = 'N', LRWORK >= 5*min(M,N). +* Otherwise, LRWORK >= 5*min(M,N)*min(M,N) + 7*min(M,N) * * IWORK (workspace) INTEGER array, dimension (8*min(M,N)) * @@ -143,14 +146,16 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) COMPLEX CZERO, CONE - PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), - $ CONE = ( 1.0E0, 0.0E0 ) ) + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) REAL ZERO, ONE - PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS + LOGICAL WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS INTEGER BLK, CHUNK, I, IE, IERR, IL, IR, IRU, IRVT, $ ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT, $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK, @@ -162,15 +167,17 @@ REAL DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL CGEBRD, CGELQF, CGEMM, CGEQRF, CLACP2, CLACPY, - $ CLACRM, CLARCM, CLASCL, CLASET, CUNGBR, CUNGLQ, - $ CUNGQR, CUNMBR, SBDSDC, SLASCL, XERBLA + EXTERNAL CGEBRD, CGELQF, CGEMM, CGEQRF, + $ CLACP2, CLACPY, CLACRM, CLARCM, + $ CLASCL, CLASET, CUNGBR, CUNGLQ, + $ CUNGQR, CUNMBR, SBDSDC, SLASCL, + $ XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV REAL CLANGE, SLAMCH - EXTERNAL CLANGE, ILAENV, LSAME, SLAMCH + EXTERNAL CLANGE, SLAMCH, ILAENV, LSAME * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, SQRT @@ -181,8 +188,8 @@ * INFO = 0 MINMN = MIN( M, N ) - MNTHR1 = INT( MINMN*17.0E0 / 9.0E0 ) - MNTHR2 = INT( MINMN*5.0E0 / 3.0E0 ) + MNTHR1 = INT( MINMN*17.0 / 9.0 ) + MNTHR2 = INT( MINMN*5.0 / 3.0 ) WNTQA = LSAME( JOBZ, 'A' ) WNTQS = LSAME( JOBZ, 'S' ) WNTQAS = WNTQA .OR. WNTQS @@ -190,7 +197,6 @@ WNTQN = LSAME( JOBZ, 'N' ) MINWRK = 1 MAXWRK = 1 - LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN INFO = -1 @@ -221,19 +227,21 @@ IF( M.GE.N ) THEN * * There is no complex work space needed for bidiagonal SVD -* The real work space needed for bidiagonal SVD is BDSPAC, -* BDSPAC = 3*N*N + 4*N +* The real work space needed for bidiagonal SVD is BDSPAC +* for computing singular values and singular vectors; BDSPAN +* for computing singular values only. +* BDSPAC = 5*N*N + 7*N +* BDSPAN = MAX(7*N+4, 3*N+2+SMLSIZ*(SMLSIZ+8)) * IF( M.GE.MNTHR1 ) THEN IF( WNTQN ) THEN * * Path 1 (M much larger than N, JOBZ='N') * - WRKBL = N + N*ILAENV( 1, 'CGEQRF', ' ', M, N, -1, - $ -1 ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) ) - MAXWRK = WRKBL + MAXWRK = N + N*ILAENV( 1, 'CGEQRF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, 2*N+2*N* + $ ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) ) MINWRK = 3*N ELSE IF( WNTQO ) THEN * @@ -335,8 +343,11 @@ ELSE * * There is no complex work space needed for bidiagonal SVD -* The real work space needed for bidiagonal SVD is BDSPAC, -* BDSPAC = 3*M*M + 4*M +* The real work space needed for bidiagonal SVD is BDSPAC +* for computing singular values and singular vectors; BDSPAN +* for computing singular values only. +* BDSPAC = 5*M*M + 7*M +* BDSPAN = MAX(7*M+4, 3*M+2+SMLSIZ*(SMLSIZ+8)) * IF( N.GE.MNTHR1 ) THEN IF( WNTQN ) THEN @@ -447,24 +458,21 @@ END IF END IF MAXWRK = MAX( MAXWRK, MINWRK ) + END IF + IF( INFO.EQ.0 ) THEN WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -13 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGESDD', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE RETURN END IF * @@ -529,7 +537,7 @@ * * Perform bidiagonal SVD, compute singular values only * (CWorkspace: 0) -* (RWorkspace: need BDSPAC) +* (RWorkspace: need BDSPAN) * CALL SBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) @@ -844,7 +852,7 @@ * * Compute singular values only * (Cworkspace: 0) -* (Rworkspace: need BDSPAC) +* (Rworkspace: need BDSPAN) * CALL SBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) @@ -1040,7 +1048,7 @@ * * Compute singular values only * (Cworkspace: 0) -* (Rworkspace: need BDSPAC) +* (Rworkspace: need BDSPAN) * CALL SBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) @@ -1205,8 +1213,8 @@ 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) +* columns than rows, first reduce using the LQ decomposition (if +* sufficient workspace available) * IF( N.GE.MNTHR1 ) THEN * @@ -1245,7 +1253,7 @@ * * Perform bidiagonal SVD, compute singular values only * (CWorkspace: 0) -* (RWorkspace: need BDSPAC) +* (RWorkspace: need BDSPAN) * CALL SBDSDC( 'U', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) @@ -1531,8 +1539,8 @@ * (CWorkspace: need M*M) * (RWorkspace: 0) * - CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IVT ), LDWKVT, - $ VT, LDVT, CZERO, A, LDA ) + CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IVT ), + $ LDWKVT, VT, LDVT, CZERO, A, LDA ) * * Copy right singular vectors of A from A to VT * @@ -1567,7 +1575,7 @@ * * Compute singular values only * (Cworkspace: 0) -* (Rworkspace: need BDSPAC) +* (Rworkspace: need BDSPAN) * CALL SBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) @@ -1763,7 +1771,7 @@ * * Compute singular values only * (Cworkspace: 0) -* (Rworkspace: need BDSPAC) +* (Rworkspace: need BDSPAN) * CALL SBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) @@ -1934,9 +1942,15 @@ IF( ANRM.GT.BIGNUM ) $ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) + IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) + $ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, + $ RWORK( IE ), MINMN, IERR ) IF( ANRM.LT.SMLNUM ) $ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) + IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) + $ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, + $ RWORK( IE ), MINMN, IERR ) END IF * * Return optimal workspace in WORK(1) diff -uNr LAPACK.orig/SRC/cgesvd.f LAPACK/SRC/cgesvd.f --- LAPACK.orig/SRC/cgesvd.f Thu Nov 4 14:24:09 1999 +++ LAPACK/SRC/cgesvd.f Fri May 25 16:08:29 2001 @@ -4,7 +4,8 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT @@ -114,12 +115,12 @@ * LWORK >= 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. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * -* RWORK (workspace) REAL array, dimension (5*min(M,N)) +* RWORK (workspace) REAL 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). @@ -137,6 +138,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) COMPLEX CZERO, CONE PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), $ CONE = ( 1.0E0, 0.0E0 ) ) @@ -144,8 +147,8 @@ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, - $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS + LOGICAL WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, WNTVA, + $ WNTVAS, WNTVN, WNTVO, WNTVS INTEGER BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL, $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, @@ -188,7 +191,7 @@ WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) MINWRK = 1 - LQUERY = ( LWORK.EQ.-1 ) + MAXWRK = 1 * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN INFO = -1 @@ -216,8 +219,7 @@ * real workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV.) * - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. - $ N.GT.0 ) THEN + IF( INFO.EQ.0 .AND. M.GT.0 .AND. N.GT.0 ) THEN IF( M.GE.N ) THEN * * Space needed for CBDSQR is BDSPAC = 5*N @@ -543,24 +545,21 @@ MAXWRK = MAX( MINWRK, MAXWRK ) END IF END IF + END IF + IF( INFO.EQ.0 ) THEN WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -13 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGESVD', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE RETURN END IF * diff -uNr LAPACK.orig/SRC/cggbak.f LAPACK/SRC/cggbak.f --- LAPACK.orig/SRC/cggbak.f Thu Nov 4 14:24:10 1999 +++ LAPACK/SRC/cggbak.f Fri May 25 16:09:01 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* February 1, 2001 * * .. Scalar Arguments .. CHARACTER JOB, SIDE @@ -109,10 +109,15 @@ INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 - ELSE IF( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) THEN + ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN + INFO = -4 + ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) + $ THEN + INFO = -5 + ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN - INFO = -6 + INFO = -8 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF diff -uNr LAPACK.orig/SRC/cggbal.f LAPACK/SRC/cggbal.f --- LAPACK.orig/SRC/cggbal.f Thu Nov 4 14:24:10 1999 +++ LAPACK/SRC/cggbal.f Fri May 25 16:09:22 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* April 12, 2001 * * .. Scalar Arguments .. CHARACTER JOB @@ -150,7 +150,7 @@ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -5 + INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGGBAL', -INFO ) @@ -197,8 +197,8 @@ IF( L.NE.1 ) $ GO TO 30 * - RSCALE( 1 ) = 1 - LSCALE( 1 ) = 1 + RSCALE( 1 ) = ONE + LSCALE( 1 ) = ONE GO TO 190 * 30 CONTINUE @@ -256,7 +256,7 @@ * Permute rows M and I * 160 CONTINUE - LSCALE( M ) = I + LSCALE( M ) = REAL( I ) IF( I.EQ.M ) $ GO TO 170 CALL CSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) @@ -265,7 +265,7 @@ * Permute columns M and J * 170 CONTINUE - RSCALE( M ) = J + RSCALE( M ) = REAL( J ) IF( J.EQ.M ) $ GO TO 180 CALL CSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) @@ -437,7 +437,7 @@ DO 360 I = ILO, IHI IRAB = ICAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) - IRAB = ICAMAX( N-ILO+1, B( I, ILO ), LDA ) + IRAB = ICAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) diff -uNr LAPACK.orig/SRC/cgges.f LAPACK/SRC/cgges.f --- LAPACK.orig/SRC/cgges.f Thu Nov 4 14:26:17 1999 +++ LAPACK/SRC/cgges.f Fri May 25 16:09:43 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SORT @@ -145,10 +146,9 @@ * 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. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) REAL array, dimension (8*N) * @@ -173,6 +173,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) COMPLEX CZERO, CONE @@ -181,7 +183,7 @@ * .. * .. Local Scalars .. LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, - $ LQUERY, WANTST + $ WANTST INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, $ ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK, LWKMIN, $ LWKOPT @@ -237,7 +239,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN @@ -264,7 +265,7 @@ * following subroutine, as returned by ILAENV.) * LWKMIN = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN LWKMIN = MAX( 1, 2*N ) LWKOPT = N + N*ILAENV( 1, 'CGEQRF', ' ', N, 1, N, 0 ) IF( ILVSL ) THEN @@ -272,21 +273,17 @@ $ -1 ) ) END IF WORK( 1 ) = LWKOPT + IF( LWORK.LT.LWKMIN .AND. LWORK.NE.LQUERV ) + $ INFO = -18 END IF * - IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) - $ INFO = -18 +* Quick return if possible * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGGES ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* - WORK( 1 ) = LWKOPT + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/cggesx.f LAPACK/SRC/cggesx.f --- LAPACK.orig/SRC/cggesx.f Thu Nov 4 14:26:17 1999 +++ LAPACK/SRC/cggesx.f Fri May 25 16:10:00 2001 @@ -7,6 +7,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Do WS calculations if LWORK = -1 (eca) * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SENSE, SORT @@ -167,6 +168,10 @@ * If SENSE = 'E', 'V', or 'B', * LWORK >= MAX(2*N, 2*SDIM*(N-SDIM)). * +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. +* * RWORK (workspace) REAL array, dimension ( 8*N ) * Real workspace. * @@ -198,6 +203,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) COMPLEX CZERO, CONE @@ -304,14 +311,22 @@ * following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + IF( INFO.EQ.0 ) THEN MINWRK = MAX( 1, 2*N ) MAXWRK = N + N*ILAENV( 1, 'CGEQRF', ' ', N, 1, N, 0 ) IF( ILVSL ) THEN MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'CUNGQR', ' ', N, 1, N, $ -1 ) ) END IF +* +* Estimate the workspace needed by CTGSEN. +* + IF( WANTST ) THEN + MAXWRK = MAX( MAXWRK, (N*N+1)/2 ) + END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -21 END IF IF( .NOT.WANTSN ) THEN LIWMIN = N+2 @@ -319,21 +334,18 @@ LIWMIN = 1 END IF IWORK( 1 ) = LIWMIN -* - IF( INFO.EQ.0 .AND. LWORK.LT.MINWRK ) THEN - INFO = -21 - ELSE IF( INFO.EQ.0 .AND. IJOB.GE.1 ) THEN + IF( INFO.EQ.0 .AND. IJOB.GE.1 ) THEN IF( LIWORK.LT.LIWMIN ) $ INFO = -24 END IF * +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGGESX', -INFO ) RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/cggev.f LAPACK/SRC/cggev.f --- LAPACK.orig/SRC/cggev.f Thu Nov 4 14:26:17 1999 +++ LAPACK/SRC/cggev.f Fri May 25 16:10:19 2001 @@ -5,6 +5,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -113,10 +114,9 @@ * 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. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace/output) REAL array, dimension (8*N) * @@ -133,6 +133,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) COMPLEX CZERO, CONE @@ -140,7 +142,7 @@ $ CONE = ( 1.0E0, 0.0E0 ) ) * .. * .. Local Scalars .. - LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR CHARACTER CHTEMP INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, $ IN, IRIGHT, IROWS, IRWRK, ITAU, IWRK, JC, JR, @@ -202,7 +204,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN @@ -228,25 +229,21 @@ * computed assuming ILO = 1 and IHI = N, the worst case.) * LWKMIN = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN LWKOPT = N + N*ILAENV( 1, 'CGEQRF', ' ', N, 1, N, 0 ) LWKMIN = MAX( 1, 2*N ) WORK( 1 ) = LWKOPT + IF( LWORK.LT.LWKMIN .AND. LWORK.NE.LQUERV ) + $ INFO = -15 END IF * - IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) - $ INFO = -15 +* Quick returns * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGGEV ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* - WORK( 1 ) = LWKOPT + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/cggevx.f LAPACK/SRC/cggevx.f --- LAPACK.orig/SRC/cggevx.f Thu Nov 4 14:26:17 1999 +++ LAPACK/SRC/cggevx.f Fri May 25 16:11:36 2001 @@ -7,6 +7,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE @@ -194,10 +195,9 @@ * If SENSE = 'N' or 'E', LWORK >= 2*N. * If SENSE = 'V' or 'B', LWORK >= 2*N*N+2*N. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) REAL array, dimension (6*N) * Real workspace. @@ -247,6 +247,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) COMPLEX CZERO, CONE @@ -254,8 +256,8 @@ $ CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. - LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, - $ WANTSB, WANTSE, WANTSN, WANTSV + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, WANTSB, + $ WANTSE, WANTSN, WANTSV CHARACTER CHTEMP INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS, $ ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK, MINWRK @@ -321,7 +323,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, $ 'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) $ THEN @@ -354,7 +355,7 @@ * computed assuming ILO = 1 and IHI = N, the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = N + N*ILAENV( 1, 'CGEQRF', ' ', N, 1, N, 0 ) IF( WANTSE ) THEN MINWRK = MAX( 1, 2*N ) @@ -363,21 +364,17 @@ MAXWRK = MAX( MAXWRK, 2*N*N+2*N ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -25 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -25 - END IF +* Quick returns * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGGEVX', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/cgghrd.f LAPACK/SRC/cgghrd.f --- LAPACK.orig/SRC/cgghrd.f Thu Nov 4 14:25:42 1999 +++ LAPACK/SRC/cgghrd.f Fri May 25 16:11:54 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ @@ -20,16 +20,29 @@ * * CGGHRD reduces a pair of complex matrices (A,B) to generalized upper * Hessenberg form using unitary transformations, where A is a -* general matrix and B is upper triangular: Q' * A * Z = H and -* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, -* and Q and Z are unitary, and ' means conjugate transpose. +* general matrix and B is upper triangular. The form of the generalized +* eigenvalue problem is +* A*x = lambda*B*x, +* and B is typically made upper triangular by computing its QR +* factorization and moving the unitary matrix Q to the left side +* of the equation. +* +* This subroutine simultaneously reduces A to a Hessenberg matrix H: +* Q**H*A*Z = H +* and transforms B to another upper triangular matrix T: +* Q**H*B*Z = T +* in order to reduce the problem to its standard form +* H*y = lambda*T*y +* where y = Z**H*x. * * The unitary matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be * postmultiplied into input matrices Q1 and Z1, so that -* -* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' -* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' +* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H +* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H +* If Q1 is the unitary matrix from the QR factorization of B in the +* original equation A*x = lambda*B*x, then CGGHRD reduces the original +* problem to generalized Hessenberg form. * * Arguments * ========= @@ -53,10 +66,11 @@ * * 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 CGGBAL; otherwise they should be set -* to 1 and N respectively. +* ILO and IHI mark the rows and columns of A which are to be +* reduced. 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 CGGBAL; otherwise they +* should be set to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) COMPLEX array, dimension (LDA, N) @@ -70,33 +84,28 @@ * * B (input/output) COMPLEX array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. -* On exit, the upper triangular matrix T = Q' B Z. The +* On exit, the upper triangular matrix T = Q**H B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) COMPLEX array, dimension (LDQ, N) -* If COMPQ='N': Q is not referenced. -* If COMPQ='I': on entry, Q need not be set, and on exit it -* contains the unitary matrix Q, where Q' -* is the product of the Givens transformations -* which are applied to A and B on the left. -* If COMPQ='V': on entry, Q must contain a unitary matrix -* Q1, and on exit this is overwritten by Q1*Q. +* On entry, if COMPQ = 'V', the unitary matrix Q1, typically +* from the QR factorization of B. +* On exit, if COMPQ='I', the unitary matrix Q, and if +* COMPQ = 'V', the product Q1*Q. +* Not referenced if COMPQ='N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * Z (input/output) COMPLEX array, dimension (LDZ, N) -* If COMPZ='N': Z is not referenced. -* If COMPZ='I': on entry, Z need not be set, and on exit it -* contains the unitary matrix Z, which is -* the product of the Givens transformations -* which are applied to A and B on the right. -* If COMPZ='V': on entry, Z must contain a unitary matrix -* Z1, and on exit this is overwritten by Z1*Z. +* On entry, if COMPZ = 'V', the unitary matrix Z1. +* On exit, if COMPZ='I', the unitary matrix Z, and if +* COMPZ = 'V', the product Z1*Z. +* Not referenced if COMPZ='N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. diff -uNr LAPACK.orig/SRC/chbgst.f LAPACK/SRC/chbgst.f --- LAPACK.orig/SRC/chbgst.f Thu Nov 4 14:23:31 1999 +++ LAPACK/SRC/chbgst.f Fri May 25 16:12:55 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* January 9, 2001 * * .. Scalar Arguments .. CHARACTER UPLO, VECT @@ -131,7 +131,7 @@ INFO = -3 ELSE IF( KA.LT.0 ) THEN INFO = -4 - ELSE IF( KB.LT.0 ) THEN + ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN INFO = -5 ELSE IF( LDAB.LT.KA+1 ) THEN INFO = -7 diff -uNr LAPACK.orig/SRC/chgeqz.f LAPACK/SRC/chgeqz.f --- LAPACK.orig/SRC/chgeqz.f Thu Nov 4 14:24:13 1999 +++ LAPACK/SRC/chgeqz.f Fri May 25 16:12:16 2001 @@ -1,43 +1,64 @@ - SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, + SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, $ RWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 3, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. REAL RWORK( * ) - COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), - $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) + COMPLEX ALPHA( * ), BETA( * ), H( LDH, * ), + $ Q( LDQ, * ), T( LDT, * ), WORK( * ), + $ Z( LDZ, * ) * .. * * Purpose * ======= * -* CHGEQZ implements a single-shift version of the QZ -* method for finding the generalized eigenvalues w(i)=ALPHA(i)/BETA(i) -* of the equation -* -* det( A - w(i) B ) = 0 -* -* If JOB='S', then the pair (A,B) is simultaneously -* reduced to Schur form (i.e., A and B are both upper triangular) by -* applying one unitary tranformation (usually called Q) on the left and -* another (usually called Z) on the right. The diagonal elements of -* A are then ALPHA(1),...,ALPHA(N), and of B are BETA(1),...,BETA(N). -* -* If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the unitary -* transformations used to reduce (A,B) are accumulated into the arrays -* Q and Z s.t.: -* -* Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* -* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* +* CHGEQZ computes the eigenvalues of a complex matrix pair (H,T), +* where H is an upper Hessenberg matrix and T is upper triangular, +* using the single-shift QZ method. +* Matrix pairs of this type are produced by the reduction to +* generalized upper Hessenberg form of a complex matrix pair (A,B): +* +* A = Q1*H*Z1**H, B = Q1*T*Z1**H, +* +* as computed by CGGHRD. +* +* If JOB='S', then the Hessenberg-triangular pair (H,T) is +* also reduced to generalized Schur form, +* +* H = Q*S*Z**H, T = Q*P*Z**H, +* +* where Q and Z are unitary matrices and S and P are upper triangular. +* +* Optionally, the unitary matrix Q from the generalized Schur +* factorization may be postmultiplied into an input matrix Q1, and the +* unitary matrix Z may be postmultiplied into an input matrix Z1. +* If Q1 and Z1 are the unitary matrices from CGGHRD that reduced +* the matrix pair (A,B) to generalized Hessenberg form, then the output +* matrices Q1*Q and Z1*Z are the unitary factors from the generalized +* Schur factorization of (A,B): +* +* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. +* +* To avoid overflow, eigenvalues of the matrix pair (H,T) +* (equivalently, of (A,B)) are computed as a pair of complex values +* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an +* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) +* A*x = lambda*B*x +* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the +* alternate form of the GNEP +* mu*A*y = B*y. +* The values of alpha and beta for the i-th eigenvalue can be read +* directly from the generalized Schur form: alpha = S(i,i), +* beta = P(i,i). * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), @@ -47,83 +68,88 @@ * ========= * * JOB (input) CHARACTER*1 -* = 'E': compute only ALPHA and BETA. A and B will not -* necessarily be put into generalized Schur form. -* = 'S': put A and B into generalized Schur form, as well -* as computing ALPHA and BETA. +* = 'E': Compute eigenvalues only; +* = 'S': Computer eigenvalues and the Schur form. * * COMPQ (input) CHARACTER*1 -* = 'N': do not modify Q. -* = 'V': multiply the array Q on the right by the conjugate -* transpose of the unitary tranformation that is -* applied to the left side of A and B to reduce them -* to Schur form. -* = 'I': like COMPQ='V', except that Q will be initialized to -* the identity first. +* = 'N': Left Schur vectors (Q) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Q +* of left Schur vectors of (H,T) is returned; +* = 'V': Q must contain a unitary matrix Q1 on entry and +* the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 -* = 'N': do not modify Z. -* = 'V': multiply the array Z on the right by the unitary -* tranformation that is applied to the right side of -* A and B to reduce them to Schur form. -* = 'I': like COMPZ='V', except that Z will be initialized to -* the identity first. +* = 'N': Right Schur vectors (Z) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Z +* of right Schur vectors of (H,T) is returned; +* = 'V': Z must contain a unitary matrix Z1 on entry and +* the product Z1*Z is returned. * * N (input) INTEGER -* The order of the matrices A, B, Q, and Z. N >= 0. +* The order of the matrices H, T, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* A (input/output) COMPLEX array, dimension (LDA, N) -* On entry, the N-by-N upper Hessenberg matrix A. Elements -* below the subdiagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to upper triangular form. -* If JOB='E', then on exit A will have been destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max( 1, N ). -* -* B (input/output) COMPLEX array, dimension (LDB, N) -* On entry, the N-by-N upper triangular matrix B. Elements -* below the diagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to upper triangular form. -* If JOB='E', then on exit B will have been destroyed. +* ILO and IHI mark the rows and columns of H which are in +* Hessenberg form. It is assumed that A is already upper +* triangular in rows and columns 1:ILO-1 and IHI+1:N. +* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. +* +* H (input/output) COMPLEX array, dimension (LDH, N) +* On entry, the N-by-N upper Hessenberg matrix H. +* On exit, if JOB = 'S', H contains the upper triangular +* matrix S from the generalized Schur factorization. +* If JOB = 'E', the diagonal of H matches that of S, but +* the rest of H is unspecified. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH >= max( 1, N ). +* +* T (input/output) COMPLEX array, dimension (LDT, N) +* On entry, the N-by-N upper triangular matrix T. +* On exit, if JOB = 'S', T contains the upper triangular +* matrix P from the generalized Schur factorization. +* If JOB = 'E', the diagonal of T matches that of P, but +* the rest of T is unspecified. * -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max( 1, N ). +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max( 1, N ). * * ALPHA (output) COMPLEX array, dimension (N) -* The diagonal elements of A when the pair (A,B) has been -* reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N -* are the generalized eigenvalues. +* The complex scalars alpha that define the eigenvalues of +* GNEP. ALPHA(i) = S(i,i) in the generalized Schur +* factorization. * * BETA (output) COMPLEX array, dimension (N) -* The diagonal elements of B when the pair (A,B) has been -* reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N -* are the generalized eigenvalues. A and B are normalized -* so that BETA(1),...,BETA(N) are non-negative real numbers. +* The real non-negative scalars beta that define the +* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized +* Schur factorization. +* +* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) +* represent the j-th eigenvalue of the matrix pair (A,B), in +* one of the forms lambda = alpha/beta or mu = beta/alpha. +* Since either lambda or mu may overflow, they should not, +* in general, be computed. * * Q (input/output) COMPLEX array, dimension (LDQ, N) -* If COMPQ='N', then Q will not be referenced. -* If COMPQ='V' or 'I', then the conjugate transpose of the -* unitary transformations which are applied to A and B on -* the left will be applied to the array Q on the right. +* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the +* reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the unitary matrix of left Schur +* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of +* left Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) COMPLEX array, dimension (LDZ, N) -* If COMPZ='N', then Z will not be referenced. -* If COMPZ='V' or 'I', then the unitary transformations which -* are applied to A and B on the right will be applied to the -* array Z on the right. +* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the +* reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the unitary matrix of right Schur +* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of +* right Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. @@ -145,13 +171,12 @@ * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value -* = 1,...,N: the QZ iteration did not converge. (A,B) is not +* = 1,...,N: the QZ iteration did not converge. (H,T) is not * in Schur form, but ALPHA(i) and BETA(i), * i=INFO+1,...,N should be correct. -* = N+1,...,2*N: the shift calculation failed. (A,B) is not +* = N+1,...,2*N: the shift calculation failed. (H,T) is not * in Schur form, but ALPHA(i) and BETA(i), * i=INFO-N+1,...,N should be correct. -* > 2*N: various "impossible" errors. * * Further Details * =============== @@ -178,7 +203,7 @@ REAL ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL, $ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP COMPLEX ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2, - $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T, + $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1, $ U12, X * .. * .. External Functions .. @@ -255,9 +280,9 @@ INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 - ELSE IF( LDA.LT.N ) THEN + ELSE IF( LDH.LT.N ) THEN INFO = -8 - ELSE IF( LDB.LT.N ) THEN + ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -14 @@ -293,8 +318,8 @@ IN = IHI + 1 - ILO SAFMIN = SLAMCH( 'S' ) ULP = SLAMCH( 'E' )*SLAMCH( 'B' ) - ANORM = CLANHS( 'F', IN, A( ILO, ILO ), LDA, RWORK ) - BNORM = CLANHS( 'F', IN, B( ILO, ILO ), LDB, RWORK ) + ANORM = CLANHS( 'F', IN, H( ILO, ILO ), LDH, RWORK ) + BNORM = CLANHS( 'F', IN, T( ILO, ILO ), LDT, RWORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) @@ -304,23 +329,23 @@ * Set Eigenvalues IHI+1:N * DO 10 J = IHI + 1, N - ABSB = ABS( B( J, J ) ) + ABSB = ABS( T( J, J ) ) IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = CONJG( B( J, J ) / ABSB ) - B( J, J ) = ABSB + SIGNBC = CONJG( T( J, J ) / ABSB ) + T( J, J ) = ABSB IF( ILSCHR ) THEN - CALL CSCAL( J-1, SIGNBC, B( 1, J ), 1 ) - CALL CSCAL( J, SIGNBC, A( 1, J ), 1 ) + CALL CSCAL( J-1, SIGNBC, T( 1, J ), 1 ) + CALL CSCAL( J, SIGNBC, H( 1, J ), 1 ) ELSE - A( J, J ) = A( J, J )*SIGNBC + H( J, J ) = H( J, J )*SIGNBC END IF IF( ILZ ) $ CALL CSCAL( N, SIGNBC, Z( 1, J ), 1 ) ELSE - B( J, J ) = CZERO + T( J, J ) = CZERO END IF - ALPHA( J ) = A( J, J ) - BETA( J ) = B( J, J ) + ALPHA( J ) = H( J, J ) + BETA( J ) = T( J, J ) 10 CONTINUE * * If IHI < ILO, skip QZ steps @@ -365,22 +390,22 @@ * Split the matrix if possible. * * Two tests: -* 1: A(j,j-1)=0 or j=ILO -* 2: B(j,j)=0 +* 1: H(j,j-1)=0 or j=ILO +* 2: T(j,j)=0 * * Special case: j=ILAST * IF( ILAST.EQ.ILO ) THEN GO TO 60 ELSE - IF( ABS1( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN - A( ILAST, ILAST-1 ) = CZERO + IF( ABS1( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = CZERO GO TO 60 END IF END IF * - IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN - B( ILAST, ILAST ) = CZERO + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = CZERO GO TO 50 END IF * @@ -388,30 +413,30 @@ * DO 40 J = ILAST - 1, ILO, -1 * -* Test 1: for A(j,j-1)=0 or j=ILO +* Test 1: for H(j,j-1)=0 or j=ILO * IF( J.EQ.ILO ) THEN ILAZRO = .TRUE. ELSE - IF( ABS1( A( J, J-1 ) ).LE.ATOL ) THEN - A( J, J-1 ) = CZERO + IF( ABS1( H( J, J-1 ) ).LE.ATOL ) THEN + H( J, J-1 ) = CZERO ILAZRO = .TRUE. ELSE ILAZRO = .FALSE. END IF END IF * -* Test 2: for B(j,j)=0 +* Test 2: for T(j,j)=0 * - IF( ABS( B( J, J ) ).LT.BTOL ) THEN - B( J, J ) = CZERO + IF( ABS( T( J, J ) ).LT.BTOL ) THEN + T( J, J ) = CZERO * * Test 1a: Check for 2 consecutive small subdiagonals in A * ILAZR2 = .FALSE. IF( .NOT.ILAZRO ) THEN - IF( ABS1( A( J, J-1 ) )*( ASCALE*ABS1( A( J+1, - $ J ) ) ).LE.ABS1( A( J, J ) )*( ASCALE*ATOL ) ) + IF( ABS1( H( J, J-1 ) )*( ASCALE*ABS1( H( J+1, + $ J ) ) ).LE.ABS1( H( J, J ) )*( ASCALE*ATOL ) ) $ ILAZR2 = .TRUE. END IF * @@ -423,21 +448,21 @@ * IF( ILAZRO .OR. ILAZR2 ) THEN DO 20 JCH = J, ILAST - 1 - CTEMP = A( JCH, JCH ) - CALL CLARTG( CTEMP, A( JCH+1, JCH ), C, S, - $ A( JCH, JCH ) ) - A( JCH+1, JCH ) = CZERO - CALL CROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA, - $ A( JCH+1, JCH+1 ), LDA, C, S ) - CALL CROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB, - $ B( JCH+1, JCH+1 ), LDB, C, S ) + CTEMP = H( JCH, JCH ) + CALL CLARTG( CTEMP, H( JCH+1, JCH ), C, S, + $ H( JCH, JCH ) ) + H( JCH+1, JCH ) = CZERO + CALL CROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH, + $ H( JCH+1, JCH+1 ), LDH, C, S ) + CALL CROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT, + $ T( JCH+1, JCH+1 ), LDT, C, S ) IF( ILQ ) $ CALL CROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, CONJG( S ) ) IF( ILAZR2 ) - $ A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C + $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C ILAZR2 = .FALSE. - IF( ABS1( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN + IF( ABS1( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN IF( JCH+1.GE.ILAST ) THEN GO TO 60 ELSE @@ -445,35 +470,35 @@ GO TO 70 END IF END IF - B( JCH+1, JCH+1 ) = CZERO + T( JCH+1, JCH+1 ) = CZERO 20 CONTINUE GO TO 50 ELSE * -* Only test 2 passed -- chase the zero to B(ILAST,ILAST) -* Then process as in the case B(ILAST,ILAST)=0 +* Only test 2 passed -- chase the zero to T(ILAST,ILAST) +* Then process as in the case T(ILAST,ILAST)=0 * DO 30 JCH = J, ILAST - 1 - CTEMP = B( JCH, JCH+1 ) - CALL CLARTG( CTEMP, B( JCH+1, JCH+1 ), C, S, - $ B( JCH, JCH+1 ) ) - B( JCH+1, JCH+1 ) = CZERO + CTEMP = T( JCH, JCH+1 ) + CALL CLARTG( CTEMP, T( JCH+1, JCH+1 ), C, S, + $ T( JCH, JCH+1 ) ) + T( JCH+1, JCH+1 ) = CZERO IF( JCH.LT.ILASTM-1 ) - $ CALL CROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB, - $ B( JCH+1, JCH+2 ), LDB, C, S ) - CALL CROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA, - $ A( JCH+1, JCH-1 ), LDA, C, S ) + $ CALL CROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT, + $ T( JCH+1, JCH+2 ), LDT, C, S ) + CALL CROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH, + $ H( JCH+1, JCH-1 ), LDH, C, S ) IF( ILQ ) $ CALL CROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, CONJG( S ) ) - CTEMP = A( JCH+1, JCH ) - CALL CLARTG( CTEMP, A( JCH+1, JCH-1 ), C, S, - $ A( JCH+1, JCH ) ) - A( JCH+1, JCH-1 ) = CZERO - CALL CROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1, - $ A( IFRSTM, JCH-1 ), 1, C, S ) - CALL CROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1, - $ B( IFRSTM, JCH-1 ), 1, C, S ) + CTEMP = H( JCH+1, JCH ) + CALL CLARTG( CTEMP, H( JCH+1, JCH-1 ), C, S, + $ H( JCH+1, JCH ) ) + H( JCH+1, JCH-1 ) = CZERO + CALL CROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1, + $ H( IFRSTM, JCH-1 ), 1, C, S ) + CALL CROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1, + $ T( IFRSTM, JCH-1 ), 1, C, S ) IF( ILZ ) $ CALL CROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, $ C, S ) @@ -497,42 +522,42 @@ INFO = 2*N + 1 GO TO 210 * -* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a +* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a * 1x1 block. * 50 CONTINUE - CTEMP = A( ILAST, ILAST ) - CALL CLARTG( CTEMP, A( ILAST, ILAST-1 ), C, S, - $ A( ILAST, ILAST ) ) - A( ILAST, ILAST-1 ) = CZERO - CALL CROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1, - $ A( IFRSTM, ILAST-1 ), 1, C, S ) - CALL CROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1, - $ B( IFRSTM, ILAST-1 ), 1, C, S ) + CTEMP = H( ILAST, ILAST ) + CALL CLARTG( CTEMP, H( ILAST, ILAST-1 ), C, S, + $ H( ILAST, ILAST ) ) + H( ILAST, ILAST-1 ) = CZERO + CALL CROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1, + $ H( IFRSTM, ILAST-1 ), 1, C, S ) + CALL CROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1, + $ T( IFRSTM, ILAST-1 ), 1, C, S ) IF( ILZ ) $ CALL CROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S ) * -* A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA +* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA * 60 CONTINUE - ABSB = ABS( B( ILAST, ILAST ) ) + ABSB = ABS( T( ILAST, ILAST ) ) IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = CONJG( B( ILAST, ILAST ) / ABSB ) - B( ILAST, ILAST ) = ABSB + SIGNBC = CONJG( T( ILAST, ILAST ) / ABSB ) + T( ILAST, ILAST ) = ABSB IF( ILSCHR ) THEN - CALL CSCAL( ILAST-IFRSTM, SIGNBC, B( IFRSTM, ILAST ), 1 ) - CALL CSCAL( ILAST+1-IFRSTM, SIGNBC, A( IFRSTM, ILAST ), + CALL CSCAL( ILAST-IFRSTM, SIGNBC, T( IFRSTM, ILAST ), 1 ) + CALL CSCAL( ILAST+1-IFRSTM, SIGNBC, H( IFRSTM, ILAST ), $ 1 ) ELSE - A( ILAST, ILAST ) = A( ILAST, ILAST )*SIGNBC + H( ILAST, ILAST ) = H( ILAST, ILAST )*SIGNBC END IF IF( ILZ ) $ CALL CSCAL( N, SIGNBC, Z( 1, ILAST ), 1 ) ELSE - B( ILAST, ILAST ) = CZERO + T( ILAST, ILAST ) = CZERO END IF - ALPHA( ILAST ) = A( ILAST, ILAST ) - BETA( ILAST ) = B( ILAST, ILAST ) + ALPHA( ILAST ) = H( ILAST, ILAST ) + BETA( ILAST ) = T( ILAST, ILAST ) * * Go to next block -- exit if finished. * @@ -565,7 +590,7 @@ * Compute the Shift. * * At this point, IFIRST < ILAST, and the diagonal elements of -* B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in +* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in * magnitude) * IF( ( IITER / 10 )*10.NE.IITER ) THEN @@ -577,33 +602,33 @@ * We factor B as U*D, where U has unit diagonals, and * compute (A*inv(D))*inv(U). * - U12 = ( BSCALE*B( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD22 = ( ASCALE*A( ILAST, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) + U12 = ( BSCALE*T( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD22 = ( ASCALE*H( ILAST, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) ABI22 = AD22 - U12*AD21 * - T = HALF*( AD11+ABI22 ) - RTDISC = SQRT( T**2+AD12*AD21-AD11*AD22 ) - TEMP = REAL( T-ABI22 )*REAL( RTDISC ) + - $ AIMAG( T-ABI22 )*AIMAG( RTDISC ) + T1 = HALF*( AD11+ABI22 ) + RTDISC = SQRT( T1**2+AD12*AD21-AD11*AD22 ) + TEMP = REAL( T1-ABI22 )*REAL( RTDISC ) + + $ AIMAG( T1-ABI22 )*AIMAG( RTDISC ) IF( TEMP.LE.ZERO ) THEN - SHIFT = T + RTDISC + SHIFT = T1 + RTDISC ELSE - SHIFT = T - RTDISC + SHIFT = T1 - RTDISC END IF ELSE * * Exceptional shift. Chosen for no particularly good reason. * - ESHIFT = ESHIFT + CONJG( ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) ) + ESHIFT = ESHIFT + CONJG( ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) ) SHIFT = ESHIFT END IF * @@ -611,46 +636,46 @@ * DO 80 J = ILAST - 1, IFIRST + 1, -1 ISTART = J - CTEMP = ASCALE*A( J, J ) - SHIFT*( BSCALE*B( J, J ) ) + CTEMP = ASCALE*H( J, J ) - SHIFT*( BSCALE*T( J, J ) ) TEMP = ABS1( CTEMP ) - TEMP2 = ASCALE*ABS1( A( J+1, J ) ) + TEMP2 = ASCALE*ABS1( H( J+1, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( ABS1( A( J, J-1 ) )*TEMP2.LE.TEMP*ATOL ) + IF( ABS1( H( J, J-1 ) )*TEMP2.LE.TEMP*ATOL ) $ GO TO 90 80 CONTINUE * ISTART = IFIRST - CTEMP = ASCALE*A( IFIRST, IFIRST ) - - $ SHIFT*( BSCALE*B( IFIRST, IFIRST ) ) + CTEMP = ASCALE*H( IFIRST, IFIRST ) - + $ SHIFT*( BSCALE*T( IFIRST, IFIRST ) ) 90 CONTINUE * * Do an implicit-shift QZ sweep. * * Initial Q * - CTEMP2 = ASCALE*A( ISTART+1, ISTART ) + CTEMP2 = ASCALE*H( ISTART+1, ISTART ) CALL CLARTG( CTEMP, CTEMP2, C, S, CTEMP3 ) * * Sweep * DO 150 J = ISTART, ILAST - 1 IF( J.GT.ISTART ) THEN - CTEMP = A( J, J-1 ) - CALL CLARTG( CTEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = CZERO + CTEMP = H( J, J-1 ) + CALL CLARTG( CTEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = CZERO END IF * DO 100 JC = J, ILASTM - CTEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -CONJG( S )*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = CTEMP - CTEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -CONJG( S )*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = CTEMP2 + CTEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -CONJG( S )*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = CTEMP + CTEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -CONJG( S )*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = CTEMP2 100 CONTINUE IF( ILQ ) THEN DO 110 JR = 1, N @@ -660,19 +685,19 @@ 110 CONTINUE END IF * - CTEMP = B( J+1, J+1 ) - CALL CLARTG( CTEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = CZERO + CTEMP = T( J+1, J+1 ) + CALL CLARTG( CTEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = CZERO * DO 120 JR = IFRSTM, MIN( J+2, ILAST ) - CTEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -CONJG( S )*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = CTEMP + CTEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -CONJG( S )*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = CTEMP 120 CONTINUE DO 130 JR = IFRSTM, J - CTEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -CONJG( S )*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = CTEMP + CTEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -CONJG( S )*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = CTEMP 130 CONTINUE IF( ILZ ) THEN DO 140 JR = 1, N @@ -700,23 +725,23 @@ * Set Eigenvalues 1:ILO-1 * DO 200 J = 1, ILO - 1 - ABSB = ABS( B( J, J ) ) + ABSB = ABS( T( J, J ) ) IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = CONJG( B( J, J ) / ABSB ) - B( J, J ) = ABSB + SIGNBC = CONJG( T( J, J ) / ABSB ) + T( J, J ) = ABSB IF( ILSCHR ) THEN - CALL CSCAL( J-1, SIGNBC, B( 1, J ), 1 ) - CALL CSCAL( J, SIGNBC, A( 1, J ), 1 ) + CALL CSCAL( J-1, SIGNBC, T( 1, J ), 1 ) + CALL CSCAL( J, SIGNBC, H( 1, J ), 1 ) ELSE - A( J, J ) = A( J, J )*SIGNBC + H( J, J ) = H( J, J )*SIGNBC END IF IF( ILZ ) $ CALL CSCAL( N, SIGNBC, Z( 1, J ), 1 ) ELSE - B( J, J ) = CZERO + T( J, J ) = CZERO END IF - ALPHA( J ) = A( J, J ) - BETA( J ) = B( J, J ) + ALPHA( J ) = H( J, J ) + BETA( J ) = T( J, J ) 200 CONTINUE * * Normal Termination diff -uNr LAPACK.orig/SRC/clasr.f LAPACK/SRC/clasr.f --- LAPACK.orig/SRC/clasr.f Thu Nov 4 14:24:17 1999 +++ LAPACK/SRC/clasr.f Fri May 25 16:12:37 2001 @@ -3,7 +3,7 @@ * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* May 3, 2001 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE @@ -17,42 +17,77 @@ * Purpose * ======= * -* CLASR performs the transformation +* CLASR applies a sequence of real plane rotations to a complex matrix +* A, from either the left or the right. * -* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) +* When SIDE = 'L', the transformation takes the form * -* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) +* A := P*A * -* where A is an m by n complex matrix and P is an orthogonal matrix, -* consisting of a sequence of plane rotations determined by the -* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' -* and z = n when SIDE = 'R' or 'r' ): +* and when SIDE = 'R', the transformation takes the form * -* When DIRECT = 'F' or 'f' ( Forward sequence ) then -* -* P = P( z - 1 )*...*P( 2 )*P( 1 ), -* -* and when DIRECT = 'B' or 'b' ( Backward sequence ) then -* -* P = P( 1 )*P( 2 )*...*P( z - 1 ), -* -* where P( k ) is a plane rotation matrix for the following planes: -* -* when PIVOT = 'V' or 'v' ( Variable pivot ), -* the plane ( k, k + 1 ) -* -* when PIVOT = 'T' or 't' ( Top pivot ), -* the plane ( 1, k + 1 ) -* -* when PIVOT = 'B' or 'b' ( Bottom pivot ), -* the plane ( k, z ) -* -* c( k ) and s( k ) must contain the cosine and sine that define the -* matrix P( k ). The two by two plane rotation part of the matrix -* P( k ), R( k ), is assumed to be of the form -* -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) +* 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 * ========= @@ -61,13 +96,13 @@ * 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' +* = 'R': Right, compute A:= A*P**T * * 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 ) +* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) +* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation @@ -84,18 +119,22 @@ * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * -* C, S (input) REAL arrays, dimension +* C (input) REAL array, dimension +* (M-1) if SIDE = 'L' +* (N-1) if SIDE = 'R' +* The cosines c(k) of the plane rotations. +* +* S (input) REAL array, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' -* c(k) and s(k) contain the cosine and sine that define the -* matrix P(k). The two by two plane rotation part of the -* matrix P(k), R(k), is assumed to be of the form -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) +* 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 array, dimension (LDA,N) -* The m by n matrix A. On exit, A is overwritten by P*A if -* SIDE = 'R' or by A*P' if SIDE = 'L'. +* 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). diff -uNr LAPACK.orig/SRC/ctgevc.f LAPACK/SRC/ctgevc.f --- LAPACK.orig/SRC/ctgevc.f Thu Nov 4 14:26:09 1999 +++ LAPACK/SRC/ctgevc.f Fri May 25 16:13:37 2001 @@ -1,19 +1,19 @@ - SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, + SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 4, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE - INTEGER INFO, LDA, LDB, LDVL, LDVR, M, MM, N + INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) REAL RWORK( * ) - COMPLEX A( LDA, * ), B( LDB, * ), VL( LDVL, * ), + COMPLEX P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * @@ -21,28 +21,30 @@ * Purpose * ======= * -* CTGEVC computes some or all of the right and/or left generalized -* eigenvectors of a pair of complex upper triangular matrices (A,B). -* -* The right generalized eigenvector x and the left generalized -* eigenvector y of (A,B) corresponding to a generalized eigenvalue -* w are defined by: -* -* (A - wB) * x = 0 and y**H * (A - wB) = 0 -* +* CTGEVC computes some or all of the right and/or left eigenvectors of +* a pair of complex matrices (S,P), where S and P are upper triangular. +* Matrix pairs of this type are produced by the generalized Schur +* factorization of a complex matrix pair (A,B): +* +* A = Q*S*Z**H, B = Q*P*Z**H +* +* as computed by CGGHRD + CHGEQZ. +* +* The right eigenvector x and the left eigenvector y of (S,P) +* corresponding to an eigenvalue w are defined by: +* +* S*x = w*P*x, (y**H)*S = w*(y**H)*P, +* * where y**H denotes the conjugate tranpose of y. -* -* If an eigenvalue w is determined by zero diagonal elements of both A -* and B, a unit vector is returned as the corresponding eigenvector. -* -* If all eigenvectors are requested, the routine may either return -* the matrices X and/or Y of right or left eigenvectors of (A,B), or -* the products Z*X and/or Q*Y, where Z and Q are input unitary -* matrices. If (A,B) was obtained from the generalized Schur -* factorization of an original pair of matrices -* (A0,B0) = (Q*A*Z**H,Q*B*Z**H), -* then Z*X and Q*Y are the matrices of right or left eigenvectors of -* A. +* The eigenvalues are not input to this routine, but are computed +* directly from the diagonal elements of S and P. +* +* This routine returns the matrices X and/or Y of right and left +* eigenvectors of (S,P), or the products Z*X and/or Q*Y, +* where Z and Q are input matrices. +* If Q and Z are the unitary factors from the generalized Schur +* factorization of a matrix pair (A,B), then Z*X and Q*Y +* are the matrices of right and left eigenvectors of (A,B). * * Arguments * ========= @@ -54,66 +56,66 @@ * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; -* = 'B': compute all right and/or left eigenvectors, and -* backtransform them using the input matrices supplied -* in VR and/or VL; +* = 'B': compute all right and/or left eigenvectors, +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY='S', SELECT specifies the eigenvectors to be -* computed. -* If HOWMNY='A' or 'B', SELECT is not referenced. -* To select the eigenvector corresponding to the j-th -* eigenvalue, SELECT(j) must be set to .TRUE.. +* 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 matrices A and B. N >= 0. -* -* A (input) COMPLEX array, dimension (LDA,N) -* The upper triangular matrix A. -* -* LDA (input) INTEGER -* The leading dimension of array A. LDA >= max(1,N). +* The order of the matrices S and P. N >= 0. * -* B (input) COMPLEX array, dimension (LDB,N) -* The upper triangular matrix B. B must have real diagonal -* elements. +* S (input) COMPLEX array, dimension (LDS,N) +* The upper triangular matrix S from a generalized Schur +* factorization, as computed by CHGEQZ. +* +* LDS (input) INTEGER +* The leading dimension of array S. LDS >= max(1,N). +* +* P (input) COMPLEX array, dimension (LDP,N) +* The upper triangular matrix P from a generalized Schur +* factorization, as computed by CHGEQZ. P must have real +* diagonal elements. * -* LDB (input) INTEGER -* The leading dimension of array B. LDB >= max(1,N). +* LDP (input) INTEGER +* The leading dimension of array P. LDP >= max(1,N). * * VL (input/output) COMPLEX 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 left Schur vectors returned by CHGEQZ). * On exit, if SIDE = 'L' or 'B', VL contains: -* if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Q*Y; -* if HOWMNY = 'S', the left eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VL, in the same order as their eigenvalues. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of array VL. -* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of array VL. LDVL >= 1, and if +* SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N. * * VR (input/output) COMPLEX 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 Z * of right Schur vectors returned by CHGEQZ). * On exit, if SIDE = 'R' or 'B', VR contains: -* if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Z*X; -* if HOWMNY = 'S', the right eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VR, in the same order as their eigenvalues. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. -* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. @@ -180,7 +182,7 @@ IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. - ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN + ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. @@ -211,9 +213,9 @@ INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN @@ -237,7 +239,7 @@ * ILBBAD = .FALSE. DO 20 J = 1, N - IF( AIMAG( B( J, J ) ).NE.ZERO ) + IF( AIMAG( P( J, J ) ).NE.ZERO ) $ ILBBAD = .TRUE. 20 CONTINUE * @@ -275,19 +277,19 @@ * part of A and B to check for possible overflow in the triangular * solver. * - ANORM = ABS1( A( 1, 1 ) ) - BNORM = ABS1( B( 1, 1 ) ) + ANORM = ABS1( S( 1, 1 ) ) + BNORM = ABS1( P( 1, 1 ) ) RWORK( 1 ) = ZERO RWORK( N+1 ) = ZERO DO 40 J = 2, N RWORK( J ) = ZERO RWORK( N+J ) = ZERO DO 30 I = 1, J - 1 - RWORK( J ) = RWORK( J ) + ABS1( A( I, J ) ) - RWORK( N+J ) = RWORK( N+J ) + ABS1( B( I, J ) ) + RWORK( J ) = RWORK( J ) + ABS1( S( I, J ) ) + RWORK( N+J ) = RWORK( N+J ) + ABS1( P( I, J ) ) 30 CONTINUE - ANORM = MAX( ANORM, RWORK( J )+ABS1( A( J, J ) ) ) - BNORM = MAX( BNORM, RWORK( N+J )+ABS1( B( J, J ) ) ) + ANORM = MAX( ANORM, RWORK( J )+ABS1( S( J, J ) ) ) + BNORM = MAX( BNORM, RWORK( N+J )+ABS1( P( J, J ) ) ) 40 CONTINUE * ASCALE = ONE / MAX( ANORM, SAFMIN ) @@ -309,8 +311,8 @@ IF( ILCOMP ) THEN IEIG = IEIG + 1 * - IF( ABS1( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( REAL( B( JE, JE ) ) ).LE.SAFMIN ) THEN + IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( REAL( P( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * @@ -326,10 +328,10 @@ * H * y ( a A - b B ) = 0 * - TEMP = ONE / MAX( ABS1( A( JE, JE ) )*ASCALE, - $ ABS( REAL( B( JE, JE ) ) )*BSCALE, SAFMIN ) - SALPHA = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*REAL( B( JE, JE ) ) )*BSCALE + TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, + $ ABS( REAL( P( JE, JE ) ) )*BSCALE, SAFMIN ) + SALPHA = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*REAL( P( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * @@ -380,7 +382,7 @@ * * Compute * j-1 -* SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) +* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * (Scale if necessary) * @@ -396,16 +398,16 @@ SUMB = CZERO * DO 80 JR = JE, J - 1 - SUMA = SUMA + CONJG( A( JR, J ) )*WORK( JR ) - SUMB = SUMB + CONJG( B( JR, J ) )*WORK( JR ) + SUMA = SUMA + CONJG( S( JR, J ) )*WORK( JR ) + SUMB = SUMB + CONJG( P( JR, J ) )*WORK( JR ) 80 CONTINUE SUM = ACOEFF*SUMA - CONJG( BCOEFF )*SUMB * -* Form x(j) = - SUM / conjg( a*A(j,j) - b*B(j,j) ) +* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) * * with scaling and perturbation of the denominator * - D = CONJG( ACOEFF*A( J, J )-BCOEFF*B( J, J ) ) + D = CONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) ) IF( ABS1( D ).LE.DMIN ) $ D = CMPLX( DMIN ) * @@ -475,8 +477,8 @@ IF( ILCOMP ) THEN IEIG = IEIG - 1 * - IF( ABS1( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( REAL( B( JE, JE ) ) ).LE.SAFMIN ) THEN + IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( REAL( P( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * @@ -492,10 +494,10 @@ * * ( a A - b B ) x = 0 * - TEMP = ONE / MAX( ABS1( A( JE, JE ) )*ASCALE, - $ ABS( REAL( B( JE, JE ) ) )*BSCALE, SAFMIN ) - SALPHA = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*REAL( B( JE, JE ) ) )*BSCALE + TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, + $ ABS( REAL( P( JE, JE ) ) )*BSCALE, SAFMIN ) + SALPHA = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*REAL( P( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * @@ -542,7 +544,7 @@ * WORK(j+1:JE) contains x * DO 170 JR = 1, JE - 1 - WORK( JR ) = ACOEFF*A( JR, JE ) - BCOEFF*B( JR, JE ) + WORK( JR ) = ACOEFF*S( JR, JE ) - BCOEFF*P( JR, JE ) 170 CONTINUE WORK( JE ) = CONE * @@ -551,7 +553,7 @@ * Form x(j) := - w(j) / d * with scaling and perturbation of the denominator * - D = ACOEFF*A( J, J ) - BCOEFF*B( J, J ) + D = ACOEFF*S( J, J ) - BCOEFF*P( J, J ) IF( ABS1( D ).LE.DMIN ) $ D = CMPLX( DMIN ) * @@ -568,7 +570,7 @@ * IF( J.GT.1 ) THEN * -* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling +* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( ABS1( WORK( J ) ).GT.ONE ) THEN TEMP = ONE / ABS1( WORK( J ) ) @@ -583,8 +585,8 @@ CA = ACOEFF*WORK( J ) CB = BCOEFF*WORK( J ) DO 200 JR = 1, J - 1 - WORK( JR ) = WORK( JR ) + CA*A( JR, J ) - - $ CB*B( JR, J ) + WORK( JR ) = WORK( JR ) + CA*S( JR, J ) - + $ CB*P( JR, J ) 200 CONTINUE END IF 210 CONTINUE diff -uNr LAPACK.orig/SRC/ctrevc.f LAPACK/SRC/ctrevc.f --- LAPACK.orig/SRC/ctrevc.f Thu Nov 4 14:24:23 1999 +++ LAPACK/SRC/ctrevc.f Fri May 25 16:13:56 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 7, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -22,20 +22,23 @@ * * CTREVC 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 CHSEQR. +* * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: -* -* T*x = w*x, y'*T = w*y' -* -* where y' denotes the conjugate transpose of the vector y. -* -* If all eigenvectors are requested, the routine may either return the -* matrices X and/or Y of right or left eigenvectors of T, or the -* products Q*X and/or Q*Y, where Q is an input unitary -* matrix. If T was obtained from the Schur factorization of an -* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of -* right or left eigenvectors of A. +* +* T*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 * ========= @@ -48,17 +51,17 @@ * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, -* and backtransform them using the input matrices -* supplied in VR and/or VL; +* backtransformed using the matrices supplied in +* VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, -* specified by the logical array SELECT. +* as indicated by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. -* If HOWMNY = 'A' or 'B', SELECT is not referenced. -* To select the eigenvector corresponding to the j-th -* eigenvalue, SELECT(j) must be set to .TRUE.. +* 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. @@ -76,19 +79,16 @@ * Schur vectors returned by CHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; -* VL is lower triangular. The i-th column -* VL(i) of VL is the eigenvector corresponding -* to T(i,i). * 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. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of the array VL. LDVL >= max(1,N) if -* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of the array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) COMPLEX array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must @@ -96,19 +96,16 @@ * Schur vectors returned by CHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; -* VR is upper triangular. The i-th column -* VR(i) of VR is the eigenvector corresponding -* to T(i,i). * 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. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. LDVR >= max(1,N) if -* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. diff -uNr LAPACK.orig/SRC/ctrsen.f LAPACK/SRC/ctrsen.f --- LAPACK.orig/SRC/ctrsen.f Thu Nov 4 14:24:24 1999 +++ LAPACK/SRC/ctrsen.f Fri May 25 16:14:15 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* January 3, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB @@ -93,14 +93,13 @@ * If JOB = 'N' or 'E', SEP is not referenced. * * WORK (workspace/output) COMPLEX array, dimension (LWORK) -* If JOB = 'N', WORK is not referenced. Otherwise, -* on exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= 1; -* if JOB = 'E', LWORK = M*(N-M); -* if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). +* if JOB = 'E', LWORK = max(1,M*(N-M)); +* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns diff -uNr LAPACK.orig/SRC/ctrsyl.f LAPACK/SRC/ctrsyl.f --- LAPACK.orig/SRC/ctrsyl.f Thu Nov 4 14:24:24 1999 +++ LAPACK/SRC/ctrsyl.f Fri May 25 16:14:25 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* January 9, 2001 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB @@ -119,11 +119,9 @@ NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 - IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. - $ LSAME( TRANA, 'C' ) ) THEN + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -1 - ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. - $ LSAME( TRANB, 'C' ) ) THEN + ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 diff -uNr LAPACK.orig/SRC/dbdsqr.f LAPACK/SRC/dbdsqr.f --- LAPACK.orig/SRC/dbdsqr.f Thu Nov 4 14:24:42 1999 +++ LAPACK/SRC/dbdsqr.f Fri May 25 15:59:00 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. CHARACTER UPLO @@ -18,14 +18,26 @@ * Purpose * ======= * -* DBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. +* DBDSQR 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**T +* +* 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**T*VT instead of +* P**T, for given real input matrices U and VT. When U and VT are the +* orthogonal matrices that reduce a general matrix A to bidiagonal +* form: A = U*B*VT, as computed by DGEBRD, then * -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given real input matrices U, VT, and C. +* A = (U*Q) * S * (P**T*VT) +* +* is the SVD of A. Optionally, the subroutine may also compute Q**T*C +* for a given real input matrix C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, @@ -61,18 +73,17 @@ * order. * * E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E +* 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. E(N) is used for workspace. * * VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. +* On exit, VT is overwritten by P**T * VT. +* Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. @@ -81,21 +92,22 @@ * U (input/output) DOUBLE PRECISION array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. -* U is not referenced if NRU = 0. +* Not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. -* On exit, C is overwritten by Q' * C. -* C is not referenced if NCC = 0. +* On exit, C is overwritten by Q**T * 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. * -* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) +* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise * * INFO (output) INTEGER * = 0: successful exit diff -uNr LAPACK.orig/SRC/dgebd2.f LAPACK/SRC/dgebd2.f --- LAPACK.orig/SRC/dgebd2.f Thu Nov 4 14:24:42 1999 +++ LAPACK/SRC/dgebd2.f Fri May 25 15:59:22 2001 @@ -3,7 +3,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* May 7, 2001 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -169,8 +169,9 @@ * * Apply H(i) to A(i:m,i+1:n) from the left * - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), - $ A( I, I+1 ), LDA, WORK ) + IF( I.LT.N ) + $ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), + $ A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN @@ -207,8 +208,9 @@ * * Apply G(i) to A(i+1:m,i:n) from the right * - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), - $ A( MIN( I+1, M ), I ), LDA, WORK ) + IF( I.LT.M ) + $ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( MIN( I+1, M ), I ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.M ) THEN diff -uNr LAPACK.orig/SRC/dgees.f LAPACK/SRC/dgees.f --- LAPACK.orig/SRC/dgees.f Thu Nov 4 14:24:43 1999 +++ LAPACK/SRC/dgees.f Fri May 25 15:59:50 2001 @@ -5,6 +5,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVS, SORT @@ -110,10 +111,9 @@ * The dimension of the array WORK. LWORK >= max(1,3*N). * For good performance, LWORK must generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * BWORK (workspace) LOGICAL array, dimension (N) * Not referenced if SORT = 'N'. @@ -138,12 +138,13 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST, - $ WANTVS + LOGICAL CURSL, LASTSL, LST2SL, SCALEA, WANTST, WANTVS INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, $ IHI, ILO, INXT, IP, ITAU, IWRK, K, MAXB, $ MAXWRK, MINWRK @@ -154,8 +155,8 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, - $ DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA + EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, + $ DLACPY, DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA * .. * .. External Functions .. LOGICAL LSAME @@ -171,7 +172,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) WANTVS = LSAME( JOBVS, 'V' ) WANTST = LSAME( SORT, 'S' ) IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN @@ -197,7 +197,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) MINWRK = MAX( 1, 3*N ) IF( .NOT.WANTVS ) THEN @@ -216,19 +216,18 @@ MAXWRK = MAX( MAXWRK, N+HSWORK, 1 ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -13 END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEES ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/dgeesx.f LAPACK/SRC/dgeesx.f --- LAPACK.orig/SRC/dgeesx.f Thu Nov 4 14:24:43 1999 +++ LAPACK/SRC/dgeesx.f Fri May 25 16:00:13 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Do WS calculations if LWORK = -1 (eca) * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT @@ -140,6 +141,10 @@ * N+2*SDIM*(N-SDIM) <= N+N*N/2. * For good performance, LWORK must generally be larger. * +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. +* * IWORK (workspace/output) INTEGER array, dimension (LIWORK) * Not referenced if SENSE = 'N' or 'E'. * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. @@ -171,6 +176,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. @@ -186,8 +193,8 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, - $ DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA + EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, + $ DLACPY, DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA * .. * .. External Functions .. LOGICAL LSAME @@ -239,7 +246,7 @@ * in the code.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) MINWRK = MAX( 1, 3*N ) IF( .NOT.WANTVS ) THEN @@ -257,21 +264,25 @@ HSWORK = MAX( K*( K+2 ), 2*N ) MAXWRK = MAX( MAXWRK, N+HSWORK, 1 ) END IF +* +* Estimate the workspace needed by DTRSEN. +* + IF( WANTST ) THEN + MAXWRK = MAX( MAXWRK, N+( N*N+1 ) / 2 ) + END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -16 END IF - IF( LWORK.LT.MINWRK ) THEN - INFO = -16 - END IF - IF( LIWORK.LT.1 ) THEN - INFO = -18 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEESX', -INFO ) RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/dgeev.f LAPACK/SRC/dgeev.f --- LAPACK.orig/SRC/dgeev.f Wed Dec 8 16:00:35 1999 +++ LAPACK/SRC/dgeev.f Fri May 25 16:00:43 2001 @@ -4,7 +4,8 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* December 8, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -98,10 +99,9 @@ * if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good * performance, LWORK must generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * INFO (output) INTEGER * = 0: successful exit @@ -114,11 +114,13 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, SCALEA, WANTVL, WANTVR + LOGICAL SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, $ MAXB, MAXWRK, MINWRK, NOUT @@ -130,8 +132,9 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, DLARTG, - $ DLASCL, DORGHR, DROT, DSCAL, DTREVC, XERBLA + EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, + $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC, + $ XERBLA * .. * .. External Functions .. LOGICAL LSAME @@ -148,7 +151,6 @@ * 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 @@ -176,7 +178,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = MAX( 1, 3*N ) @@ -197,19 +199,18 @@ MAXWRK = MAX( MAXWRK, 4*N ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -13 END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEEV ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/dgeevx.f LAPACK/SRC/dgeevx.f --- LAPACK.orig/SRC/dgeevx.f Thu Nov 4 14:24:43 1999 +++ LAPACK/SRC/dgeevx.f Fri May 25 16:01:05 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE @@ -179,10 +180,9 @@ * LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). * For good performance, LWORK must generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * IWORK (workspace) INTEGER array, dimension (2*N-2) * If SENSE = 'N' or 'E', not referenced. @@ -198,12 +198,14 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, - $ WNTSNN, WNTSNV + LOGICAL SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, WNTSNN, + $ WNTSNV CHARACTER JOB, SIDE INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXB, $ MAXWRK, MINWRK, NOUT @@ -215,9 +217,9 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, DLARTG, - $ DLASCL, DORGHR, DROT, DSCAL, DTREVC, DTRSNA, - $ XERBLA + EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, + $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC, + $ DTRSNA, XERBLA * .. * .. External Functions .. LOGICAL LSAME @@ -234,7 +236,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) WANTVL = LSAME( JOBVL, 'V' ) WANTVR = LSAME( JOBVR, 'V' ) WNTSNN = LSAME( SENSE, 'N' ) @@ -274,7 +275,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = MAX( 1, 2*N ) @@ -308,19 +309,18 @@ MAXWRK = MAX( MAXWRK, 3*N, 1 ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -21 END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -21 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEEVX', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/dgegs.f LAPACK/SRC/dgegs.f --- LAPACK.orig/SRC/dgegs.f Thu Nov 4 14:24:43 1999 +++ LAPACK/SRC/dgegs.f Fri May 25 16:01:53 2001 @@ -5,7 +5,7 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR @@ -22,105 +22,75 @@ * * This routine is deprecated and has been replaced by routine DGGES. * -* DGEGS computes for a pair of N-by-N real nonsymmetric matrices A, B: -* the generalized eigenvalues (alphar +/- alphai*i, beta), the real -* Schur form (A, B), and optionally left and/or right Schur vectors -* (VSL and VSR). -* -* (If only the generalized eigenvalues are needed, use the driver DGEGV -* instead.) -* -* A generalized eigenvalue for a pair of matrices (A,B) is, roughly -* speaking, a scalar w or a ratio alpha/beta = w, such that A - w*B -* is singular. It is usually represented as the pair (alpha,beta), -* as there is a reasonable interpretation for beta=0, and even for -* both being zero. A good beginning reference is the book, "Matrix -* Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press) -* -* The (generalized) Schur form of a pair of matrices is the result of -* multiplying both matrices on the left by one orthogonal matrix and -* both on the right by another orthogonal matrix, these two orthogonal -* matrices being chosen so as to bring the pair of matrices into -* (real) Schur form. -* -* A pair of matrices A, B is in generalized real Schur form if B is -* upper triangular with non-negative diagonal and A is block upper -* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond -* to real generalized eigenvalues, while 2-by-2 blocks of A will be -* "standardized" by making the corresponding elements of B have the -* form: -* [ a 0 ] -* [ 0 b ] -* -* and the pair of corresponding 2-by-2 blocks in A and B will -* have a complex conjugate pair of generalized eigenvalues. -* -* The left and right Schur vectors are the columns of VSL and VSR, -* respectively, where VSL and VSR are the orthogonal matrices -* which reduce A and B to Schur form: -* -* Schur form of (A,B) = ( (VSL)**T A (VSR), (VSL)**T B (VSR) ) +* DGEGS computes the eigenvalues, real Schur form, and, optionally, +* left and or/right Schur vectors of a real matrix pair (A,B). +* Given two square matrices A and B, the generalized real Schur +* factorization has the form +* +* A = Q*S*Z**T, B = Q*T*Z**T +* +* where Q and Z are orthogonal matrices, T is upper triangular, and S +* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal +* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs +* of eigenvalues of (A,B). The columns of Q are the left Schur vectors +* and the columns of Z are the right Schur vectors. +* +* If only the eigenvalues of (A,B) are needed, the driver routine +* DGEGV should be used instead. See DGEGV for a description of the +* eigenvalues of the generalized nonsymmetric eigenvalue problem +* (GNEP). * * Arguments * ========= * * JOBVSL (input) CHARACTER*1 * = 'N': do not compute the left Schur vectors; -* = 'V': compute the left Schur vectors. +* = 'V': compute the left Schur vectors (returned in VSL). * * JOBVSR (input) CHARACTER*1 * = 'N': do not compute the right Schur vectors; -* = 'V': compute the right Schur vectors. +* = 'V': compute the right Schur vectors (returned in VSR). * * N (input) INTEGER * The order of the matrices A, B, VSL, and VSR. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) -* On entry, the first of the pair of matrices whose generalized -* eigenvalues and (optionally) Schur vectors are to be -* computed. -* On exit, the generalized Schur form of A. -* Note: to avoid overflow, the Frobenius norm of the matrix -* A should be less than the overflow threshold. +* On entry, the matrix A. +* On exit, the upper quasi-triangular matrix S from the +* generalized real Schur factorization. * * LDA (input) INTEGER * The leading dimension of A. LDA >= max(1,N). * * B (input/output) DOUBLE PRECISION array, dimension (LDB, N) -* On entry, the second of the pair of matrices whose -* generalized eigenvalues and (optionally) Schur vectors are -* to be computed. -* On exit, the generalized Schur form of B. -* Note: to avoid overflow, the Frobenius norm of the matrix -* B should be less than the overflow threshold. +* On entry, the matrix B. +* On exit, the upper triangular matrix T from the generalized +* real Schur factorization. * * LDB (input) INTEGER * The leading dimension of B. LDB >= max(1,N). * * ALPHAR (output) DOUBLE PRECISION array, dimension (N) +* The real parts of each scalar alpha defining an eigenvalue +* of GNEP. +* * ALPHAI (output) DOUBLE PRECISION array, dimension (N) -* BETA (output) DOUBLE PRECISION array, dimension (N) -* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will -* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, -* j=1,...,N and BETA(j),j=1,...,N are the diagonals of the -* complex Schur form (A,B) that would result if the 2-by-2 -* diagonal blocks of the real Schur form of (A,B) were further -* reduced to triangular form using 2-by-2 complex unitary -* transformations. If ALPHAI(j) is zero, then the j-th +* The imaginary parts of each scalar alpha defining an +* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th * eigenvalue is real; if positive, then the j-th and (j+1)-st -* eigenvalues are a complex conjugate pair, with ALPHAI(j+1) -* negative. +* eigenvalues are a complex conjugate pair, with +* ALPHAI(j+1) = -ALPHAI(j). * -* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) -* may easily over- or underflow, and BETA(j) may even be zero. -* Thus, the user should avoid naively computing the ratio -* alpha/beta. However, ALPHAR and ALPHAI will be always less -* than and usually comparable with norm(A) in magnitude, and -* BETA always less than and usually comparable with norm(B). +* BETA (output) DOUBLE PRECISION array, dimension (N) +* The scalars beta that define the eigenvalues of GNEP. +* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and +* beta = BETA(j) represent the j-th eigenvalue of the matrix +* pair (A,B), in one of the forms lambda = alpha/beta or +* mu = beta/alpha. Since either lambda or mu may overflow, +* they should not, in general, be computed. * * VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) -* If JOBVSL = 'V', VSL will contain the left Schur vectors. -* (See "Purpose", above.) +* If JOBVSL = 'V', the matrix of left Schur vectors Q. * Not referenced if JOBVSL = 'N'. * * LDVSL (input) INTEGER @@ -128,8 +98,7 @@ * if JOBVSL = 'V', LDVSL >= N. * * VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) -* If JOBVSR = 'V', VSR will contain the right Schur vectors. -* (See "Purpose", above.) +* If JOBVSR = 'V', the matrix of right Schur vectors Z. * Not referenced if JOBVSR = 'N'. * * LDVSR (input) INTEGER diff -uNr LAPACK.orig/SRC/dgegv.f LAPACK/SRC/dgegv.f --- LAPACK.orig/SRC/dgegv.f Thu Nov 4 14:25:43 1999 +++ LAPACK/SRC/dgegv.f Fri May 25 16:02:16 2001 @@ -4,7 +4,7 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -21,23 +21,32 @@ * * This routine is deprecated and has been replaced by routine DGGEV. * -* DGEGV computes for a pair of n-by-n real nonsymmetric matrices A and -* B, the generalized eigenvalues (alphar +/- alphai*i, beta), and -* optionally, the left and/or right generalized eigenvectors (VL and -* VR). -* -* A generalized eigenvalue for a pair of matrices (A,B) is, roughly -* speaking, a scalar w or a ratio alpha/beta = w, such that A - w*B -* is singular. It is usually represented as the pair (alpha,beta), -* as there is a reasonable interpretation for beta=0, and even for -* both being zero. A good beginning reference is the book, "Matrix -* Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press) -* -* A right generalized eigenvector corresponding to a generalized -* eigenvalue w for a pair of matrices (A,B) is a vector r such -* that (A - w B) r = 0 . A left generalized eigenvector is a vector -* l such that l**H * (A - w B) = 0, where l**H is the -* conjugate-transpose of l. +* DGEGV computes the eigenvalues and, optionally, the left and/or right +* eigenvectors of a real matrix pair (A,B). +* Given two square matrices A and B, +* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the +* eigenvalues lambda and corresponding (non-zero) eigenvectors x such +* that +* +* A*x = lambda*B*x. +* +* An alternate form is to find the eigenvalues mu and corresponding +* eigenvectors y such that +* +* mu*A*y = B*y. +* +* These two forms are equivalent with mu = 1/lambda and x = y if +* neither lambda nor mu is zero. In order to deal with the case that +* lambda or mu is zero or small, two values alpha and beta are returned +* for each eigenvalue, such that lambda = alpha/beta and +* mu = beta/alpha. +* +* The vectors x and y in the above equations are right eigenvectors of +* the matrix pair (A,B). Vectors u and v satisfying +* +* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B +* +* are left eigenvectors of (A,B). * * Note: this routine performs "full balancing" on A and B -- see * "Further Details", below. @@ -47,63 +56,75 @@ * * JOBVL (input) CHARACTER*1 * = 'N': do not compute the left generalized eigenvectors; -* = 'V': compute the left generalized eigenvectors. +* = 'V': compute the left generalized eigenvectors (returned +* in VL). * * JOBVR (input) CHARACTER*1 * = 'N': do not compute the right generalized eigenvectors; -* = 'V': compute the right generalized eigenvectors. +* = 'V': compute the right generalized eigenvectors (returned +* in VR). * * N (input) INTEGER * The order of the matrices A, B, VL, and VR. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) -* On entry, the first of the pair of matrices whose -* generalized eigenvalues and (optionally) generalized -* eigenvectors are to be computed. -* On exit, the contents will have been destroyed. (For a -* description of the contents of A on exit, see "Further -* Details", below.) +* On entry, the matrix A. +* If JOBVL = 'V' or JOBVR = 'V', then on exit A +* contains the real Schur form of A from the generalized Schur +* factorization of the pair (A,B) after balancing. +* If no eigenvectors were computed, then only the diagonal +* blocks from the Schur form will be correct. See DGGHRD and +* DHGEQZ for details. * * LDA (input) INTEGER * The leading dimension of A. LDA >= max(1,N). * * B (input/output) DOUBLE PRECISION array, dimension (LDB, N) -* On entry, the second of the pair of matrices whose -* generalized eigenvalues and (optionally) generalized -* eigenvectors are to be computed. -* On exit, the contents will have been destroyed. (For a -* description of the contents of B on exit, see "Further -* Details", below.) +* On entry, the matrix B. +* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the +* upper triangular matrix obtained from B in the generalized +* Schur factorization of the pair (A,B) after balancing. +* If no eigenvectors were computed, then only those elements of +* B corresponding to the diagonal blocks from the Schur form of +* A will be correct. See DGGHRD and DHGEQZ for details. * * LDB (input) INTEGER * The leading dimension of B. LDB >= max(1,N). * * ALPHAR (output) DOUBLE PRECISION array, dimension (N) +* The real parts of each scalar alpha defining an eigenvalue of +* GNEP. +* * ALPHAI (output) DOUBLE PRECISION array, dimension (N) -* BETA (output) DOUBLE PRECISION array, dimension (N) -* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will -* be the generalized eigenvalues. If ALPHAI(j) is zero, then -* the j-th eigenvalue is real; if positive, then the j-th and +* The imaginary parts of each scalar alpha defining an +* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th +* eigenvalue is real; if positive, then the j-th and * (j+1)-st eigenvalues are a complex conjugate pair, with -* ALPHAI(j+1) negative. +* ALPHAI(j+1) = -ALPHAI(j). * -* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) -* may easily over- or underflow, and BETA(j) may even be zero. -* Thus, the user should avoid naively computing the ratio -* alpha/beta. However, ALPHAR and ALPHAI will be always less -* than and usually comparable with norm(A) in magnitude, and -* BETA always less than and usually comparable with norm(B). +* BETA (output) DOUBLE PRECISION array, dimension (N) +* The scalars beta that define the eigenvalues of GNEP. +* +* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and +* beta = BETA(j) represent the j-th eigenvalue of the matrix +* pair (A,B), in one of the forms lambda = alpha/beta or +* mu = beta/alpha. Since either lambda or mu may overflow, +* they should not, in general, be computed. * * VL (output) DOUBLE PRECISION array, dimension (LDVL,N) -* If JOBVL = 'V', the left generalized eigenvectors. (See -* "Purpose", above.) Real eigenvectors take one column, -* complex take two columns, the first for the real part and -* the second for the imaginary part. Complex eigenvectors -* correspond to an eigenvalue with positive imaginary part. -* Each eigenvector will be scaled so the largest component -* will have abs(real part) + abs(imag. part) = 1, *except* -* that for eigenvalues with alpha=beta=0, a zero vector will -* be returned as the corresponding eigenvector. +* If JOBVL = 'V', the left eigenvectors u(j) are stored +* in the columns of VL, in the same order as their eigenvalues. +* If the j-th eigenvalue is real, then u(j) = VL(:,j). +* If the j-th and (j+1)-st eigenvalues form a complex conjugate +* pair, then +* u(j) = VL(:,j) + i*VL(:,j+1) +* and +* u(j+1) = VL(:,j) - i*VL(:,j+1). +* +* Each eigenvector is scaled so that its largest component has +* abs(real part) + abs(imag. part) = 1, except for eigenvectors +* corresponding to an eigenvalue with alpha = beta = 0, which +* are set to zero. * Not referenced if JOBVL = 'N'. * * LDVL (input) INTEGER @@ -111,15 +132,19 @@ * if JOBVL = 'V', LDVL >= N. * * VR (output) DOUBLE PRECISION array, dimension (LDVR,N) -* If JOBVR = 'V', the right generalized eigenvectors. (See -* "Purpose", above.) Real eigenvectors take one column, -* complex take two columns, the first for the real part and -* the second for the imaginary part. Complex eigenvectors -* correspond to an eigenvalue with positive imaginary part. -* Each eigenvector will be scaled so the largest component -* will have abs(real part) + abs(imag. part) = 1, *except* -* that for eigenvalues with alpha=beta=0, a zero vector will -* be returned as the corresponding eigenvector. +* If JOBVR = 'V', the right eigenvectors x(j) are stored +* in the columns of VR, in the same order as their eigenvalues. +* If the j-th eigenvalue is real, then x(j) = VR(:,j). +* If the j-th and (j+1)-st eigenvalues form a complex conjugate +* pair, then +* x(j) = VR(:,j) + i*VR(:,j+1) +* and +* x(j+1) = VR(:,j) - i*VR(:,j+1). +* +* Each eigenvector is scaled so that its largest component has +* abs(real part) + abs(imag. part) = 1, except for eigenvalues +* corresponding to an eigenvalue with alpha = beta = 0, which +* are set to zero. * Not referenced if JOBVR = 'N'. * * LDVR (input) INTEGER diff -uNr LAPACK.orig/SRC/dgelsd.f LAPACK/SRC/dgelsd.f --- LAPACK.orig/SRC/dgelsd.f Thu Nov 4 14:26:25 1999 +++ LAPACK/SRC/dgelsd.f Fri May 25 16:03:10 2001 @@ -4,7 +4,8 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -61,9 +62,10 @@ * The number of right hand sides, i.e., the number of columns * of the matrices B and X. NRHS >= 0. * -* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the M-by-N matrix A. -* On exit, A has been destroyed. +* On exit, the first min(m,n) rows of A are overwritten with +* its right singular vectors, stored rowwise. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). @@ -95,23 +97,20 @@ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER -* The dimension of the array WORK. LWORK must be at least 1. +* The dimension of the array WORK. LWORK >= 1. * The exact minimum amount of workspace needed depends on M, -* N and NRHS. As long as LWORK is at least -* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, -* if M is greater than or equal to N or -* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, -* if M is less than N, the code will execute correctly. +* N and NRHS. +* If M >= N, LWORK >= 11*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS. +* If M < N, LWORK >= 11*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS. * SMLSIZ is returned by ILAENV and is equal to the maximum * size of the subproblems at the bottom of the computation * tree (usually about 25), and -* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) +* NLVL = INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * IWORK (workspace) INTEGER array, dimension (LIWORK) * LIWORK >= 3 * MINMN * NLVL + 11 * MINMN, @@ -135,14 +134,15 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ, $ LDWORK, MAXMN, MAXWRK, MINMN, MINWRK, MM, - $ MNTHR, NLVL, NWORK, SMLSIZ, WLALSD + $ MNTHR, NLVL, NWORK, SMLSIZ DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM * .. * .. External Subroutines .. @@ -165,7 +165,6 @@ MINMN = MIN( M, N ) MAXMN = MAX( M, N ) MNTHR = ILAENV( 6, 'DGELSD', ' ', M, N, NRHS, -1 ) - LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN @@ -189,8 +188,8 @@ * MINWRK = 1 MINMN = MAX( 1, MINMN ) - NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) / - $ LOG( TWO ) ) + 1, 0 ) + NLVL = INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + $ + 1 * IF( INFO.EQ.0 ) THEN MAXWRK = 0 @@ -215,12 +214,11 @@ $ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) ) MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, N, -1 ) ) - WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2 - MAXWRK = MAX( MAXWRK, 3*N+WLALSD ) - MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD ) + MAXWRK = MAX( MAXWRK, 3*N+8*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS ) + MINWRK = MAX( 3*N+MM, 3*N+NRHS, + $ 3*N+8*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS ) END IF IF( N.GT.M ) THEN - WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2 IF( N.GE.MNTHR ) THEN * * Path 2a - underdetermined, with many more columns @@ -240,7 +238,8 @@ END IF MAXWRK = MAX( MAXWRK, M+NRHS* $ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD ) + MAXWRK = MAX( MAXWRK, M*M+4*M+8*M+2*M*SMLSIZ+8*M*NLVL+M* + $ NRHS ) ELSE * * Path 2 - remaining underdetermined cases. @@ -251,26 +250,26 @@ $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, N, -1 ) ) MAXWRK = MAX( MAXWRK, 3*M+M* $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*M+WLALSD ) + MAXWRK = MAX( MAXWRK, 3*M+8*M+2*M*SMLSIZ+8*M*NLVL+M* + $ NRHS ) END IF - MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD ) + MINWRK = MAX( 3*M+NRHS, 3*M+M, + $ 3*M+8*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS ) END IF MINWRK = MIN( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -12 END IF * +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELSD', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - GO TO 10 END IF -* -* Quick return if possible. -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( M.EQ.0 .OR. N.EQ.0 ) THEN RANK = 0 RETURN diff -uNr LAPACK.orig/SRC/dgelss.f LAPACK/SRC/dgelss.f --- LAPACK.orig/SRC/dgelss.f Thu Nov 4 14:24:44 1999 +++ LAPACK/SRC/dgelss.f Fri May 25 16:03:46 2001 @@ -4,7 +4,7 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -86,10 +86,9 @@ * LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * INFO (output) INTEGER * = 0: successful exit @@ -156,7 +155,7 @@ * following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 0 MM = M IF( M.GE.N .AND. M.GE.MNTHR ) THEN @@ -229,20 +228,18 @@ END IF MAXWRK = MAX( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 END IF * - MINWRK = MAX( MINWRK, 1 ) - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELSS', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF -* -* Quick return if possible -* IF( M.EQ.0 .OR. N.EQ.0 ) THEN RANK = 0 RETURN @@ -491,8 +488,8 @@ DO 40 I = 1, NRHS, CHUNK BL = MIN( NRHS-I+1, CHUNK ) CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, - $ B( 1, I ), LDB, ZERO, WORK( IWORK ), N ) - CALL DLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ), + $ B( 1, I ), LDB, ZERO, WORK( IWORK ), M ) + CALL DLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), $ LDB ) 40 CONTINUE ELSE diff -uNr LAPACK.orig/SRC/dgesdd.f LAPACK/SRC/dgesdd.f --- LAPACK.orig/SRC/dgesdd.f Thu Nov 11 20:32:31 1999 +++ LAPACK/SRC/dgesdd.f Fri May 25 16:07:58 2001 @@ -4,7 +4,8 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBZ @@ -116,16 +117,20 @@ * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= 1. * If JOBZ = 'N', -* LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)). +* LWORK >= max(14*min(M,N)+4, 10*min(M,N)+2+ +* SMLSIZ*(SMLSIZ+8)) + max(M,N) +* where SMLSIZ is returned by ILAENV and is equal to the +* maximum size of the subproblems at the bottom of the +* computation tree (usually about 25). * If JOBZ = 'O', -* LWORK >= 3*min(M,N)*min(M,N) + -* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)). +* LWORK >= 5*min(M,N)*min(M,N) + max(M,N) + 9*min(M,N). * If JOBZ = 'S' or 'A' -* LWORK >= 3*min(M,N)*min(M,N) + -* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)). +* LWORK >= 4*min(M,N)*min(M,N) + max(M,N) + 9*min(M,N). * For good performance, LWORK should generally be larger. -* If LWORK < 0 but other input arguments are legal, WORK(1) -* returns the optimal LWORK. +* +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * IWORK (workspace) INTEGER array, dimension (8*min(M,N)) * @@ -144,15 +149,17 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS - INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IL, + LOGICAL WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS + INTEGER BDSPAC, BDSPAN, BLK, CHUNK, I, IE, IERR, IL, $ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT, $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK, - $ MNTHR, NWORK, WRKBL + $ MNTHR, NWORK, SMLSIZ, WRKBL DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM * .. * .. Local Arrays .. @@ -168,7 +175,7 @@ LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME + EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT @@ -187,7 +194,6 @@ WNTQN = LSAME( JOBZ, 'N' ) MINWRK = 1 MAXWRK = 1 - LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN INFO = -1 @@ -206,6 +212,8 @@ INFO = -10 END IF * + SMLSIZ = ILAENV( 9, 'DGESDD', ' ', 0, 0, 0, 0 ) +* * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, @@ -218,22 +226,19 @@ * * Compute space needed for DBDSDC * - IF( WNTQN ) THEN - BDSPAC = 7*N - ELSE - BDSPAC = 3*N*N + 4*N - END IF + BDSPAC = 3*N*N + 7*N + BDSPAN = MAX( 12*N+4, 8*N+2+SMLSIZ*( SMLSIZ+8 ) ) IF( M.GE.MNTHR ) THEN IF( WNTQN ) THEN * * Path 1 (M much larger than N, JOBZ='N') * - WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, - $ -1 ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+N ) - MINWRK = BDSPAC + N + MAXWRK = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, 3*N+2*N* + $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MINWRK = BDSPAC ELSE IF( WNTQO ) THEN * * Path 2 (M much larger than N, JOBZ='O') @@ -247,9 +252,9 @@ $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) ) WRKBL = MAX( WRKBL, 3*N+N* $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) + WRKBL = MAX( WRKBL, BDSPAC+2*N ) MAXWRK = WRKBL + 2*N*N - MINWRK = BDSPAC + 2*N*N + 3*N + MINWRK = BDSPAC + 2*N*N + 2*N ELSE IF( WNTQS ) THEN * * Path 3 (M much larger than N, JOBZ='S') @@ -263,9 +268,9 @@ $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) ) WRKBL = MAX( WRKBL, 3*N+N* $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) + WRKBL = MAX( WRKBL, BDSPAC+2*N ) MAXWRK = WRKBL + N*N - MINWRK = BDSPAC + N*N + 3*N + MINWRK = BDSPAC + N*N + 2*N ELSE IF( WNTQA ) THEN * * Path 4 (M much larger than N, JOBZ='A') @@ -279,9 +284,9 @@ $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) ) WRKBL = MAX( WRKBL, 3*N+N* $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) - MAXWRK = WRKBL + N*N - MINWRK = BDSPAC + N*N + 3*N + WRKBL = MAX( WRKBL, BDSPAC+2*N ) + MAXWRK = N*N + WRKBL + MINWRK = BDSPAC + N*N + M + N END IF ELSE * @@ -289,53 +294,47 @@ * WRKBL = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1, $ -1 ) - IF( WNTQN ) THEN - MAXWRK = MAX( WRKBL, BDSPAC+3*N ) - MINWRK = 3*N + MAX( M, BDSPAC ) - ELSE IF( WNTQO ) THEN + IF( WNTQO ) THEN WRKBL = MAX( WRKBL, 3*N+N* $ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) ) WRKBL = MAX( WRKBL, 3*N+N* $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) + WRKBL = MAX( WRKBL, BDSPAC+2*N+M ) MAXWRK = WRKBL + M*N - MINWRK = 3*N + MAX( M, N*N+BDSPAC ) + MINWRK = BDSPAC + N*N + 2*N + M ELSE IF( WNTQS ) THEN - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+3*N ) - MINWRK = 3*N + MAX( M, BDSPAC ) + MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC+2*N+M ) + MINWRK = BDSPAC + 2*N + M ELSE IF( WNTQA ) THEN - WRKBL = MAX( WRKBL, 3*N+M* - $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC+3*N ) - MINWRK = 3*N + MAX( M, BDSPAC ) + MAXWRK = MAX( MAXWRK, 3*N+M* + $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC+2*N+M ) + MINWRK = BDSPAC + 2*N + M END IF END IF ELSE * * Compute space needed for DBDSDC * - IF( WNTQN ) THEN - BDSPAC = 7*M - ELSE - BDSPAC = 3*M*M + 4*M - END IF + BDSPAC = 3*M*M + 7*M + BDSPAN = MAX( 12*M+4, 8*M+2+SMLSIZ*( SMLSIZ+8 ) ) IF( N.GE.MNTHR ) THEN IF( WNTQN ) THEN * * Path 1t (N much larger than M, JOBZ='N') * - WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, - $ -1 ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+M ) - MINWRK = BDSPAC + M + MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, 3*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MINWRK = BDSPAC ELSE IF( WNTQO ) THEN * * Path 2t (N much larger than M, JOBZ='O') @@ -349,9 +348,9 @@ $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) ) WRKBL = MAX( WRKBL, 3*M+M* $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) + WRKBL = MAX( WRKBL, BDSPAC+2*M ) MAXWRK = WRKBL + 2*M*M - MINWRK = BDSPAC + 2*M*M + 3*M + MINWRK = BDSPAC + 2*M*M + 2*M ELSE IF( WNTQS ) THEN * * Path 3t (N much larger than M, JOBZ='S') @@ -365,9 +364,9 @@ $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) ) WRKBL = MAX( WRKBL, 3*M+M* $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) + WRKBL = MAX( WRKBL, BDSPAC+2*M ) MAXWRK = WRKBL + M*M - MINWRK = BDSPAC + M*M + 3*M + MINWRK = BDSPAC + M*M + 2*M ELSE IF( WNTQA ) THEN * * Path 4t (N much larger than M, JOBZ='A') @@ -381,9 +380,9 @@ $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) ) WRKBL = MAX( WRKBL, 3*M+M* $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) + WRKBL = MAX( WRKBL, BDSPAC+2*M ) MAXWRK = WRKBL + M*M - MINWRK = BDSPAC + M*M + 3*M + MINWRK = BDSPAC + M*M + M + N END IF ELSE * @@ -391,52 +390,47 @@ * WRKBL = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1, $ -1 ) - IF( WNTQN ) THEN - MAXWRK = MAX( WRKBL, BDSPAC+3*M ) - MINWRK = 3*M + MAX( N, BDSPAC ) - ELSE IF( WNTQO ) THEN + IF( WNTQO ) THEN WRKBL = MAX( WRKBL, 3*M+M* $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) WRKBL = MAX( WRKBL, 3*M+M* $ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) + WRKBL = MAX( WRKBL, BDSPAC+2*M ) MAXWRK = WRKBL + M*N - MINWRK = 3*M + MAX( N, M*M+BDSPAC ) + MINWRK = BDSPAC + M*M + 2*M + N ELSE IF( WNTQS ) THEN - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+3*M ) - MINWRK = 3*M + MAX( N, BDSPAC ) + MAXWRK = MAX( MAXWRK, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC+2*M ) + MINWRK = BDSPAC + 2*M + N ELSE IF( WNTQA ) THEN - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+3*M ) - MINWRK = 3*M + MAX( N, BDSPAC ) + MAXWRK = MAX( MAXWRK, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M+N* + $ ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC+2*M ) + MINWRK = BDSPAC + 2*M + N END IF END IF END IF + END IF + IF( INFO.EQ.0 ) THEN WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -12 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESDD', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE RETURN END IF * @@ -497,7 +491,7 @@ NWORK = IE + N * * Perform bidiagonal SVD, computing singular values only -* (Workspace: need N+BDSPAC) +* (Workspace: need BDSPAN) * CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) @@ -512,10 +506,10 @@ * * WORK(IR) is LDWRKR by N * - IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN + IF( LWORK.GE.LDA*N+4*N*N+9*N ) THEN LDWRKR = LDA ELSE - LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N + LDWRKR = ( LWORK-4*N*N-9*N ) / N END IF ITAU = IR + LDWRKR*N NWORK = ITAU + N @@ -557,7 +551,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT -* (Workspace: need N+N*N+BDSPAC) +* (Workspace: need 2*N*N+BDSPAC) * CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -633,7 +627,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagoal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need N+BDSPAC) +* (Workspace: need N*N+BDSPAC) * CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -681,7 +675,7 @@ CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * @@ -703,7 +697,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT -* (Workspace: need N+N*N+BDSPAC) +* (Workspace: need N*N+BDSPAC) * CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -754,13 +748,13 @@ IF( WNTQN ) THEN * * Perform bidiagonal SVD, only computing singular values -* (Workspace: need N+BDSPAC) +* (Workspace: need BDSPAN) * CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN IU = NWORK - IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN + IF( LWORK.GE.M*N+3*N*N+9*N ) THEN * * WORK( IU ) is M by N * @@ -785,7 +779,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT -* (Workspace: need N+N*N+BDSPAC) +* (Workspace: need N*N+BDSPAC) * CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), $ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ), @@ -798,7 +792,7 @@ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK-NWORK+1, IERR ) * - IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN + IF( LWORK.GE.M*N+3*N*N+9*N ) THEN * * Overwrite WORK(IU) by left singular vectors of A * (Workspace: need N*N+2*N, prefer N*N+N+N*NB) @@ -838,7 +832,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need N+BDSPAC) +* (Workspace: need BDSPAC) * CALL DLASET( 'F', M, N, ZERO, ZERO, U, LDU ) CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, @@ -855,12 +849,12 @@ CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK-NWORK+1, IERR ) - ELSE IF( WNTQA ) THEN + ELSE * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need N+BDSPAC) +* (Workspace: need BDSPAC) * CALL DLASET( 'F', M, M, ZERO, ZERO, U, LDU ) CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, @@ -925,7 +919,7 @@ NWORK = IE + M * * Perform bidiagonal SVD, computing singular values only -* (Workspace: need M+BDSPAC) +* (Workspace: need BDSPAN) * CALL DBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) @@ -941,7 +935,7 @@ * IVT is M by M * IL = IVT + M*M - IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN + IF( LWORK.GE.M*N+4*M*M+9*M ) THEN * * WORK(IL) is M by N * @@ -986,7 +980,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U, and computing right singular * vectors of bidiagonal matrix in WORK(IVT) -* (Workspace: need M+M*M+BDSPAC) +* (Workspace: need 2*M*M+BDSPAC) * CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ), @@ -1061,7 +1055,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need M+BDSPAC) +* (Workspace: need M*M+BDSPAC) * CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -1108,7 +1102,7 @@ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -1131,7 +1125,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in WORK(IVT) -* (Workspace: need M+M*M+BDSPAC) +* (Workspace: need M*M+BDSPAC) * CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), LDWKVT, DUM, IDUM, @@ -1182,14 +1176,14 @@ IF( WNTQN ) THEN * * Perform bidiagonal SVD, only computing singular values -* (Workspace: need M+BDSPAC) +* (Workspace: need BDSPAN) * CALL DBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN LDWKVT = M IVT = NWORK - IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN + IF( LWORK.GE.M*N+3*M*M+9*M ) THEN * * WORK( IVT ) is M by N * @@ -1224,7 +1218,7 @@ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK-NWORK+1, IERR ) * - IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN + IF( LWORK.GE.M*N+3*M*M+9*M ) THEN * * Overwrite WORK(IVT) by left singular vectors of A * (Workspace: need M*M+2*M, prefer M*M+M+M*NB) @@ -1263,7 +1257,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need M+BDSPAC) +* (Workspace: need BDSPAC) * CALL DLASET( 'F', M, N, ZERO, ZERO, VT, LDVT ) CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, @@ -1280,12 +1274,12 @@ CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK-NWORK+1, IERR ) - ELSE IF( WNTQA ) THEN + ELSE * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need M+BDSPAC) +* (Workspace: need BDSPAC) * CALL DLASET( 'F', N, N, ZERO, ZERO, VT, LDVT ) CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, @@ -1319,9 +1313,15 @@ IF( ANRM.GT.BIGNUM ) $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) + IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) + $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ), + $ MINMN, IERR ) IF( ANRM.LT.SMLNUM ) $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) + IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ), + $ MINMN, IERR ) END IF * * Return optimal workspace in WORK(1) diff -uNr LAPACK.orig/SRC/dgesvd.f LAPACK/SRC/dgesvd.f --- LAPACK.orig/SRC/dgesvd.f Thu Nov 4 14:24:44 1999 +++ LAPACK/SRC/dgesvd.f Fri May 25 16:08:25 2001 @@ -4,7 +4,8 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT @@ -118,10 +119,9 @@ * LWORK >= MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * INFO (output) INTEGER * = 0: successful exit. @@ -134,12 +134,14 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) 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 + LOGICAL WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, WNTVA, + $ WNTVAS, WNTVN, WNTVO, WNTVS INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL, $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, @@ -181,7 +183,7 @@ WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) MINWRK = 1 - LQUERY = ( LWORK.EQ.-1 ) + MAXWRK = 1 * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN INFO = -1 @@ -208,8 +210,7 @@ * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. - $ N.GT.0 ) THEN + IF( INFO.EQ.0 .AND. M.GT.0 .AND. N.GT.0 ) THEN IF( M.GE.N ) THEN * * Compute space needed for DBDSQR @@ -557,24 +558,22 @@ MAXWRK = MAX( MAXWRK, MINWRK ) END IF END IF + END IF + IF( INFO.EQ.0 ) THEN WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -13 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESVD', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE RETURN END IF * diff -uNr LAPACK.orig/SRC/dggbak.f LAPACK/SRC/dggbak.f --- LAPACK.orig/SRC/dggbak.f Thu Nov 4 14:24:45 1999 +++ LAPACK/SRC/dggbak.f Fri May 25 16:08:56 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* February 1, 2001 * * .. Scalar Arguments .. CHARACTER JOB, SIDE @@ -108,10 +108,15 @@ INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 - ELSE IF( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) THEN + ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN + INFO = -4 + ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) + $ THEN + INFO = -5 + ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN - INFO = -6 + INFO = -8 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF diff -uNr LAPACK.orig/SRC/dggbal.f LAPACK/SRC/dggbal.f --- LAPACK.orig/SRC/dggbal.f Thu Nov 4 14:25:44 1999 +++ LAPACK/SRC/dggbal.f Fri May 25 16:09:17 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* April 12, 2001 * * .. Scalar Arguments .. CHARACTER JOB @@ -141,7 +141,7 @@ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -5 + INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGBAL', -INFO ) @@ -188,8 +188,8 @@ IF( L.NE.1 ) $ GO TO 30 * - RSCALE( 1 ) = 1 - LSCALE( 1 ) = 1 + RSCALE( 1 ) = ONE + LSCALE( 1 ) = ONE GO TO 190 * 30 CONTINUE @@ -247,7 +247,7 @@ * Permute rows M and I * 160 CONTINUE - LSCALE( M ) = I + LSCALE( M ) = DBLE( I ) IF( I.EQ.M ) $ GO TO 170 CALL DSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) @@ -256,7 +256,7 @@ * Permute columns M and J * 170 CONTINUE - RSCALE( M ) = J + RSCALE( M ) = DBLE( J ) IF( J.EQ.M ) $ GO TO 180 CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) @@ -424,7 +424,7 @@ DO 360 I = ILO, IHI IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) - IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDA ) + IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) diff -uNr LAPACK.orig/SRC/dgges.f LAPACK/SRC/dgges.f --- LAPACK.orig/SRC/dgges.f Thu Nov 4 14:26:18 1999 +++ LAPACK/SRC/dgges.f Fri May 25 16:09:38 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SORT @@ -158,10 +159,9 @@ * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= 8*N+16. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * BWORK (workspace) LOGICAL array, dimension (N) * Not referenced if SORT = 'N'. @@ -184,12 +184,14 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, - $ LQUERY, LST2SL, WANTST + $ LST2SL, WANTST INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, $ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, MAXWRK, $ MINWRK @@ -245,7 +247,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN @@ -272,7 +273,7 @@ * following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MINWRK = 7*( N+1 ) + 16 MAXWRK = 7*( N+1 ) + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) + $ 16 @@ -281,19 +282,18 @@ $ ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -19 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -19 +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGES ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/dggesx.f LAPACK/SRC/dggesx.f --- LAPACK.orig/SRC/dggesx.f Thu Nov 4 14:26:18 1999 +++ LAPACK/SRC/dggesx.f Fri May 25 16:09:56 2001 @@ -7,6 +7,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Do WS calculations if LWORK = -1 (eca) * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SENSE, SORT @@ -185,6 +186,10 @@ * If SENSE = 'E', 'V', or 'B', * LWORK >= MAX( 8*(N+1)+16, 2*SDIM*(N-SDIM) ). * +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. +* * IWORK (workspace) INTEGER array, dimension (LIWORK) * Not referenced if SENSE = 'N'. * @@ -227,6 +232,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. @@ -330,7 +337,7 @@ * following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + IF( INFO.EQ.0 ) THEN MINWRK = 8*( N+1 ) + 16 MAXWRK = 7*( N+1 ) + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) + $ 16 @@ -338,7 +345,15 @@ MAXWRK = MAX( MAXWRK, 8*( N+1 )+N* $ ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 )+16 ) END IF +* +* Estimate the workspace needed by DTGSEN. +* + IF( WANTST ) THEN + MAXWRK = MAX( MAXWRK, 2*N+( N*N+1 ) / 2 ) + END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -22 END IF IF( .NOT.WANTSN ) THEN LIWMIN = 1 @@ -346,21 +361,19 @@ LIWMIN = N + 6 END IF IWORK( 1 ) = LIWMIN -* - IF( INFO.EQ.0 .AND. LWORK.LT.MINWRK ) THEN - INFO = -22 - ELSE IF( INFO.EQ.0 .AND. IJOB.GE.1 ) THEN + IF( INFO.EQ.0 .AND. IJOB.GE.1 ) THEN IF( LIWORK.LT.LIWMIN ) $ INFO = -24 END IF * +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGESX', -INFO ) RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/dggev.f LAPACK/SRC/dggev.f --- LAPACK.orig/SRC/dggev.f Thu Nov 4 14:26:18 1999 +++ LAPACK/SRC/dggev.f Fri May 25 16:10:14 2001 @@ -5,6 +5,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -123,10 +124,9 @@ * The dimension of the array WORK. LWORK >= max(1,8*N). * For good performance, LWORK must generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * INFO (output) INTEGER * = 0: successful exit @@ -141,11 +141,13 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR CHARACTER CHTEMP INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, $ IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, MAXWRK, @@ -157,8 +159,9 @@ LOGICAL LDUMMA( 1 ) * .. * .. External Subroutines .. - EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY, - $ DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, XERBLA + EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD, + $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, + $ XERBLA * .. * .. External Functions .. LOGICAL LSAME @@ -199,7 +202,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN @@ -225,24 +227,22 @@ * computed assuming ILO = 1 and IHI = N, the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 7*N + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) MINWRK = MAX( 1, 8*N ) WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -16 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -16 +* Quick returns * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGEV ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/dggevx.f LAPACK/SRC/dggevx.f --- LAPACK.orig/SRC/dggevx.f Thu Nov 4 14:26:18 1999 +++ LAPACK/SRC/dggevx.f Fri May 25 16:11:31 2001 @@ -7,6 +7,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE @@ -212,10 +213,9 @@ * If SENSE = 'E', LWORK >= 12*N. * If SENSE = 'V' or 'B', LWORK >= 2*N*N+12*N+16. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * IWORK (workspace) INTEGER array, dimension (N+6) * If SENSE = 'E', IWORK is not referenced. @@ -262,12 +262,14 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, PAIR, - $ WANTSB, WANTSE, WANTSN, WANTSV + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, PAIR, WANTSB, + $ WANTSE, WANTSN, WANTSV CHARACTER CHTEMP INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS, $ ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK, @@ -279,9 +281,9 @@ LOGICAL LDUMMA( 1 ) * .. * .. External Subroutines .. - EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY, - $ DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, DTGSNA, - $ XERBLA + EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD, + $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, + $ DTGSNA, XERBLA * .. * .. External Functions .. LOGICAL LSAME @@ -327,7 +329,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, $ 'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) $ THEN @@ -360,7 +361,7 @@ * computed assuming ILO = 1 and IHI = N, the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 5*N + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) MINWRK = MAX( 1, 6*N ) IF( WANTSE ) THEN @@ -370,24 +371,20 @@ MAXWRK = MAX( MAXWRK, 2*N*N+12*N+16 ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -26 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -26 - END IF +* Quick returns * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGEVX', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) $ RETURN -* * * Get machine constants * diff -uNr LAPACK.orig/SRC/dgghrd.f LAPACK/SRC/dgghrd.f --- LAPACK.orig/SRC/dgghrd.f Thu Nov 4 14:25:43 1999 +++ LAPACK/SRC/dgghrd.f Fri May 25 16:11:50 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ @@ -20,16 +20,32 @@ * * DGGHRD reduces a pair of real matrices (A,B) to generalized upper * Hessenberg form using orthogonal transformations, where A is a -* general matrix and B is upper triangular: Q' * A * Z = H and -* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, -* and Q and Z are orthogonal, and ' means transpose. +* general matrix and B is upper triangular. The form of the +* generalized eigenvalue problem is +* A*x = lambda*B*x, +* and B is typically made upper triangular by computing its QR +* factorization and moving the orthogonal matrix Q to the left side +* of the equation. +* +* This subroutine simultaneously reduces A to a Hessenberg matrix H: +* Q**T*A*Z = H +* and transforms B to another upper triangular matrix T: +* Q**T*B*Z = T +* in order to reduce the problem to its standard form +* H*y = lambda*T*y +* where y = Z**T*x. * * The orthogonal matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be * postmultiplied into input matrices Q1 and Z1, so that * -* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' -* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' +* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T +* +* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T +* +* If Q1 is the orthogonal matrix from the QR factorization of B in the +* original equation A*x = lambda*B*x, then DGGHRD reduces the original +* problem to generalized Hessenberg form. * * Arguments * ========= @@ -53,10 +69,11 @@ * * ILO (input) INTEGER * IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally set -* by a previous call to DGGBAL; otherwise they should be set -* to 1 and N respectively. +* ILO and IHI mark the rows and columns of A which are to be +* reduced. 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 SGGBAL; otherwise they +* should be set to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) @@ -70,33 +87,28 @@ * * B (input/output) DOUBLE PRECISION array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. -* On exit, the upper triangular matrix T = Q' B Z. The +* On exit, the upper triangular matrix T = Q**T B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) -* If COMPQ='N': Q is not referenced. -* If COMPQ='I': on entry, Q need not be set, and on exit it -* contains the orthogonal matrix Q, where Q' -* is the product of the Givens transformations -* which are applied to A and B on the left. -* If COMPQ='V': on entry, Q must contain an orthogonal matrix -* Q1, and on exit this is overwritten by Q1*Q. +* On entry, if COMPQ = 'V', the orthogonal matrix Q1, +* typically from the QR factorization of B. +* On exit, if COMPQ='I', the orthogonal matrix Q, and if +* COMPQ = 'V', the product Q1*Q. +* Not referenced if COMPQ='N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) -* If COMPZ='N': Z is not referenced. -* If COMPZ='I': on entry, Z need not be set, and on exit it -* contains the orthogonal matrix Z, which is -* the product of the Givens transformations -* which are applied to A and B on the right. -* If COMPZ='V': on entry, Z must contain an orthogonal matrix -* Z1, and on exit this is overwritten by Z1*Z. +* On entry, if COMPZ = 'V', the orthogonal matrix Z1. +* On exit, if COMPZ='I', the orthogonal matrix Z, and if +* COMPZ = 'V', the product Z1*Z. +* Not referenced if COMPZ='N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. diff -uNr LAPACK.orig/SRC/dhgeqz.f LAPACK/SRC/dhgeqz.f --- LAPACK.orig/SRC/dhgeqz.f Thu Nov 4 14:24:45 1999 +++ LAPACK/SRC/dhgeqz.f Fri May 25 16:12:11 2001 @@ -1,56 +1,75 @@ - SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, + SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 3, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), - $ B( LDB, * ), BETA( * ), Q( LDQ, * ), WORK( * ), - $ Z( LDZ, * ) + DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), + $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), + $ WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * -* DHGEQZ implements a single-/double-shift version of the QZ method for -* finding the generalized eigenvalues -* -* w(j)=(ALPHAR(j) + i*ALPHAI(j))/BETAR(j) of the equation -* -* det( A - w(i) B ) = 0 -* -* In addition, the pair A,B may be reduced to generalized Schur form: -* B is upper triangular, and A is block upper triangular, where the -* diagonal blocks are either 1-by-1 or 2-by-2, the 2-by-2 blocks having -* complex generalized eigenvalues (see the description of the argument -* JOB.) -* -* If JOB='S', then the pair (A,B) is simultaneously reduced to Schur -* form by applying one orthogonal tranformation (usually called Q) on -* the left and another (usually called Z) on the right. The 2-by-2 -* upper-triangular diagonal blocks of B corresponding to 2-by-2 blocks -* of A will be reduced to positive diagonal matrices. (I.e., -* if A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) and -* B(j+1,j+1) will be positive.) -* -* If JOB='E', then at each iteration, the same transformations -* are computed, but they are only applied to those parts of A and B -* which are needed to compute ALPHAR, ALPHAI, and BETAR. -* -* If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the orthogonal -* transformations used to reduce (A,B) are accumulated into the arrays -* Q and Z s.t.: -* -* Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* -* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* +* DHGEQZ computes the eigenvalues of a real matrix pair (H,T), +* where H is an upper Hessenberg matrix and T is upper triangular, +* using the double-shift QZ method. +* Matrix pairs of this type are produced by the reduction to +* generalized upper Hessenberg form of a real matrix pair (A,B): +* +* A = Q1*H*Z1**T, B = Q1*T*Z1**T, +* +* as computed by DGGHRD. +* +* If JOB='S', then the Hessenberg-triangular pair (H,T) is +* also reduced to generalized Schur form, +* +* H = Q*S*Z**T, T = Q*P*Z**T, +* +* where Q and Z are orthogonal matrices, P is an upper triangular +* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 +* diagonal blocks. +* +* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair +* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of +* eigenvalues. +* +* Additionally, the 2-by-2 upper triangular diagonal blocks of P +* corresponding to 2-by-2 blocks of S are reduced to positive diagonal +* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, +* P(j,j) > 0, and P(j+1,j+1) > 0. +* +* Optionally, the orthogonal matrix Q from the generalized Schur +* factorization may be postmultiplied into an input matrix Q1, and the +* orthogonal matrix Z may be postmultiplied into an input matrix Z1. +* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced +* the matrix pair (A,B) to generalized upper Hessenberg form, then the +* output matrices Q1*Q and Z1*Z are the orthogonal factors from the +* generalized Schur factorization of (A,B): +* +* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. +* +* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, +* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is +* complex and beta real. +* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the +* generalized nonsymmetric eigenvalue problem (GNEP) +* A*x = lambda*B*x +* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the +* alternate form of the GNEP +* mu*A*y = B*y. +* Real eigenvalues can be read directly from the generalized Schur +* form: +* alpha = S(i,i), beta = P(i,i). * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), @@ -60,114 +79,98 @@ * ========= * * JOB (input) CHARACTER*1 -* = 'E': compute only ALPHAR, ALPHAI, and BETA. A and B will -* not necessarily be put into generalized Schur form. -* = 'S': put A and B into generalized Schur form, as well -* as computing ALPHAR, ALPHAI, and BETA. +* = 'E': Compute eigenvalues only; +* = 'S': Compute eigenvalues and the Schur form. * * COMPQ (input) CHARACTER*1 -* = 'N': do not modify Q. -* = 'V': multiply the array Q on the right by the transpose of -* the orthogonal tranformation that is applied to the -* left side of A and B to reduce them to Schur form. -* = 'I': like COMPQ='V', except that Q will be initialized to -* the identity first. +* = 'N': Left Schur vectors (Q) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Q +* of left Schur vectors of (H,T) is returned; +* = 'V': Q must contain an orthogonal matrix Q1 on entry and +* the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 -* = 'N': do not modify Z. -* = 'V': multiply the array Z on the right by the orthogonal -* tranformation that is applied to the right side of -* A and B to reduce them to Schur form. -* = 'I': like COMPZ='V', except that Z will be initialized to -* the identity first. +* = 'N': Right Schur vectors (Z) are not computed; +* = 'I': Z is initialized to the unit matrix and the matrix Z +* of right Schur vectors of (H,T) is returned; +* = 'V': Z must contain an orthogonal matrix Z1 on entry and +* the product Z1*Z is returned. * * N (input) INTEGER -* The order of the matrices A, B, Q, and Z. N >= 0. +* The order of the matrices H, T, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) -* On entry, the N-by-N upper Hessenberg matrix A. Elements -* below the subdiagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to generalized Schur form. -* If JOB='E', then on exit A will have been destroyed. -* The diagonal blocks will be correct, but the off-diagonal -* portion will be meaningless. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max( 1, N ). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) -* On entry, the N-by-N upper triangular matrix B. Elements -* below the diagonal must be zero. 2-by-2 blocks in B -* corresponding to 2-by-2 blocks in A will be reduced to -* positive diagonal form. (I.e., if A(j+1,j) is non-zero, -* then B(j+1,j)=B(j,j+1)=0 and B(j,j) and B(j+1,j+1) will be -* positive.) -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to Schur form. -* If JOB='E', then on exit B will have been destroyed. -* Elements corresponding to diagonal blocks of A will be -* correct, but the off-diagonal portion will be meaningless. +* ILO and IHI mark the rows and columns of H which are in +* Hessenberg form. It is assumed that A is already upper +* triangular in rows and columns 1:ILO-1 and IHI+1:N. +* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. +* +* H (input/output) DOUBLE PRECISION array, dimension (LDH, N) +* On entry, the N-by-N upper Hessenberg matrix H. +* On exit, if JOB = 'S', H contains the upper quasi-triangular +* matrix S from the generalized Schur factorization; +* 2-by-2 diagonal blocks (corresponding to complex conjugate +* pairs of eigenvalues) are returned in standard form, with +* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. +* If JOB = 'E', the diagonal blocks of H match those of S, but +* the rest of H is unspecified. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH >= max( 1, N ). +* +* T (input/output) DOUBLE PRECISION array, dimension (LDT, N) +* On entry, the N-by-N upper triangular matrix T. +* On exit, if JOB = 'S', T contains the upper triangular +* matrix P from the generalized Schur factorization; +* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S +* are reduced to positive diagonal form, i.e., if H(j+1,j) is +* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and +* T(j+1,j+1) > 0. +* If JOB = 'E', the diagonal blocks of T match those of P, but +* the rest of T is unspecified. * -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max( 1, N ). +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max( 1, N ). * * ALPHAR (output) DOUBLE PRECISION array, dimension (N) -* ALPHAR(1:N) will be set to real parts of the diagonal -* elements of A that would result from reducing A and B to -* Schur form and then further reducing them both to triangular -* form using unitary transformations s.t. the diagonal of B -* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=A(j,j). -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. +* The real parts of each scalar alpha defining an eigenvalue +* of GNEP. * * ALPHAI (output) DOUBLE PRECISION array, dimension (N) -* ALPHAI(1:N) will be set to imaginary parts of the diagonal -* elements of A that would result from reducing A and B to -* Schur form and then further reducing them both to triangular -* form using unitary transformations s.t. the diagonal of B -* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=0. -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. +* The imaginary parts of each scalar alpha defining an +* eigenvalue of GNEP. +* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if +* positive, then the j-th and (j+1)-st eigenvalues are a +* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). * * BETA (output) DOUBLE PRECISION array, dimension (N) -* BETA(1:N) will be set to the (real) diagonal elements of B -* that would result from reducing A and B to Schur form and -* then further reducing them both to triangular form using -* unitary transformations s.t. the diagonal of B was -* non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then BETA(j)=B(j,j). -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. -* (Note that BETA(1:N) will always be non-negative, and no -* BETAI is necessary.) +* The scalars beta that define the eigenvalues of GNEP. +* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and +* beta = BETA(j) represent the j-th eigenvalue of the matrix +* pair (A,B), in one of the forms lambda = alpha/beta or +* mu = beta/alpha. Since either lambda or mu may overflow, +* they should not, in general, be computed. * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) -* If COMPQ='N', then Q will not be referenced. -* If COMPQ='V' or 'I', then the transpose of the orthogonal -* transformations which are applied to A and B on the left -* will be applied to the array Q on the right. +* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur +* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix +* of left Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) -* If COMPZ='N', then Z will not be referenced. -* If COMPZ='V' or 'I', then the orthogonal transformations -* which are applied to A and B on the right will be applied -* to the array Z on the right. +* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of +* right Schur vectors of (H,T), and if COMPZ = 'V', the +* orthogonal matrix of right Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. @@ -187,13 +190,12 @@ * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value -* = 1,...,N: the QZ iteration did not converge. (A,B) is not +* = 1,...,N: the QZ iteration did not converge. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO+1,...,N should be correct. -* = N+1,...,2*N: the shift calculation failed. (A,B) is not +* = N+1,...,2*N: the shift calculation failed. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO-N+1,...,N should be correct. -* > 2*N: various "impossible" errors. * * Further Details * =============== @@ -225,7 +227,7 @@ $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, - $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T, + $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, $ WR2 @@ -302,9 +304,9 @@ INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 - ELSE IF( LDA.LT.N ) THEN + ELSE IF( LDH.LT.N ) THEN INFO = -8 - ELSE IF( LDB.LT.N ) THEN + ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -15 @@ -340,8 +342,8 @@ SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) - ANORM = DLANHS( 'F', IN, A( ILO, ILO ), LDA, WORK ) - BNORM = DLANHS( 'F', IN, B( ILO, ILO ), LDB, WORK ) + ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) + BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) @@ -350,15 +352,15 @@ * Set Eigenvalues IHI+1:N * DO 30 J = IHI + 1, N - IF( B( J, J ).LT.ZERO ) THEN + IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 10 JR = 1, J - A( JR, J ) = -A( JR, J ) - B( JR, J ) = -B( JR, J ) + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) 10 CONTINUE ELSE - A( J, J ) = -A( J, J ) - B( J, J ) = -B( J, J ) + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 20 JR = 1, N @@ -366,9 +368,9 @@ 20 CONTINUE END IF END IF - ALPHAR( J ) = A( J, J ) + ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO - BETA( J ) = B( J, J ) + BETA( J ) = T( J, J ) 30 CONTINUE * * If IHI < ILO, skip QZ steps @@ -408,8 +410,8 @@ * Split the matrix if possible. * * Two tests: -* 1: A(j,j-1)=0 or j=ILO -* 2: B(j,j)=0 +* 1: H(j,j-1)=0 or j=ILO +* 2: T(j,j)=0 * IF( ILAST.EQ.ILO ) THEN * @@ -417,14 +419,14 @@ * GO TO 80 ELSE - IF( ABS( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN - A( ILAST, ILAST-1 ) = ZERO + IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = ZERO GO TO 80 END IF END IF * - IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN - B( ILAST, ILAST ) = ZERO + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = ZERO GO TO 70 END IF * @@ -432,36 +434,36 @@ * DO 60 J = ILAST - 1, ILO, -1 * -* Test 1: for A(j,j-1)=0 or j=ILO +* Test 1: for H(j,j-1)=0 or j=ILO * IF( J.EQ.ILO ) THEN ILAZRO = .TRUE. ELSE - IF( ABS( A( J, J-1 ) ).LE.ATOL ) THEN - A( J, J-1 ) = ZERO + IF( ABS( H( J, J-1 ) ).LE.ATOL ) THEN + H( J, J-1 ) = ZERO ILAZRO = .TRUE. ELSE ILAZRO = .FALSE. END IF END IF * -* Test 2: for B(j,j)=0 +* Test 2: for T(j,j)=0 * - IF( ABS( B( J, J ) ).LT.BTOL ) THEN - B( J, J ) = ZERO + IF( ABS( T( J, J ) ).LT.BTOL ) THEN + T( J, J ) = ZERO * * Test 1a: Check for 2 consecutive small subdiagonals in A * ILAZR2 = .FALSE. IF( .NOT.ILAZRO ) THEN - TEMP = ABS( A( J, J-1 ) ) - TEMP2 = ABS( A( J, J ) ) + TEMP = ABS( H( J, J-1 ) ) + TEMP2 = ABS( H( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( TEMP*( ASCALE*ABS( A( J+1, J ) ) ).LE.TEMP2* + IF( TEMP*( ASCALE*ABS( H( J+1, J ) ) ).LE.TEMP2* $ ( ASCALE*ATOL ) )ILAZR2 = .TRUE. END IF * @@ -473,21 +475,21 @@ * IF( ILAZRO .OR. ILAZR2 ) THEN DO 40 JCH = J, ILAST - 1 - TEMP = A( JCH, JCH ) - CALL DLARTG( TEMP, A( JCH+1, JCH ), C, S, - $ A( JCH, JCH ) ) - A( JCH+1, JCH ) = ZERO - CALL DROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA, - $ A( JCH+1, JCH+1 ), LDA, C, S ) - CALL DROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB, - $ B( JCH+1, JCH+1 ), LDB, C, S ) + TEMP = H( JCH, JCH ) + CALL DLARTG( TEMP, H( JCH+1, JCH ), C, S, + $ H( JCH, JCH ) ) + H( JCH+1, JCH ) = ZERO + CALL DROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH, + $ H( JCH+1, JCH+1 ), LDH, C, S ) + CALL DROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT, + $ T( JCH+1, JCH+1 ), LDT, C, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) IF( ILAZR2 ) - $ A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C + $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C ILAZR2 = .FALSE. - IF( ABS( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN + IF( ABS( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN IF( JCH+1.GE.ILAST ) THEN GO TO 80 ELSE @@ -495,35 +497,35 @@ GO TO 110 END IF END IF - B( JCH+1, JCH+1 ) = ZERO + T( JCH+1, JCH+1 ) = ZERO 40 CONTINUE GO TO 70 ELSE * -* Only test 2 passed -- chase the zero to B(ILAST,ILAST) -* Then process as in the case B(ILAST,ILAST)=0 +* Only test 2 passed -- chase the zero to T(ILAST,ILAST) +* Then process as in the case T(ILAST,ILAST)=0 * DO 50 JCH = J, ILAST - 1 - TEMP = B( JCH, JCH+1 ) - CALL DLARTG( TEMP, B( JCH+1, JCH+1 ), C, S, - $ B( JCH, JCH+1 ) ) - B( JCH+1, JCH+1 ) = ZERO + TEMP = T( JCH, JCH+1 ) + CALL DLARTG( TEMP, T( JCH+1, JCH+1 ), C, S, + $ T( JCH, JCH+1 ) ) + T( JCH+1, JCH+1 ) = ZERO IF( JCH.LT.ILASTM-1 ) - $ CALL DROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB, - $ B( JCH+1, JCH+2 ), LDB, C, S ) - CALL DROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA, - $ A( JCH+1, JCH-1 ), LDA, C, S ) + $ CALL DROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT, + $ T( JCH+1, JCH+2 ), LDT, C, S ) + CALL DROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH, + $ H( JCH+1, JCH-1 ), LDH, C, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) - TEMP = A( JCH+1, JCH ) - CALL DLARTG( TEMP, A( JCH+1, JCH-1 ), C, S, - $ A( JCH+1, JCH ) ) - A( JCH+1, JCH-1 ) = ZERO - CALL DROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1, - $ A( IFRSTM, JCH-1 ), 1, C, S ) - CALL DROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1, - $ B( IFRSTM, JCH-1 ), 1, C, S ) + TEMP = H( JCH+1, JCH ) + CALL DLARTG( TEMP, H( JCH+1, JCH-1 ), C, S, + $ H( JCH+1, JCH ) ) + H( JCH+1, JCH-1 ) = ZERO + CALL DROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1, + $ H( IFRSTM, JCH-1 ), 1, C, S ) + CALL DROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1, + $ T( IFRSTM, JCH-1 ), 1, C, S ) IF( ILZ ) $ CALL DROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, $ C, S ) @@ -547,34 +549,34 @@ INFO = N + 1 GO TO 420 * -* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a +* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a * 1x1 block. * 70 CONTINUE - TEMP = A( ILAST, ILAST ) - CALL DLARTG( TEMP, A( ILAST, ILAST-1 ), C, S, - $ A( ILAST, ILAST ) ) - A( ILAST, ILAST-1 ) = ZERO - CALL DROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1, - $ A( IFRSTM, ILAST-1 ), 1, C, S ) - CALL DROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1, - $ B( IFRSTM, ILAST-1 ), 1, C, S ) + TEMP = H( ILAST, ILAST ) + CALL DLARTG( TEMP, H( ILAST, ILAST-1 ), C, S, + $ H( ILAST, ILAST ) ) + H( ILAST, ILAST-1 ) = ZERO + CALL DROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1, + $ H( IFRSTM, ILAST-1 ), 1, C, S ) + CALL DROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1, + $ T( IFRSTM, ILAST-1 ), 1, C, S ) IF( ILZ ) $ CALL DROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S ) * -* A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, +* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, * and BETA * 80 CONTINUE - IF( B( ILAST, ILAST ).LT.ZERO ) THEN + IF( T( ILAST, ILAST ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 90 J = IFRSTM, ILAST - A( J, ILAST ) = -A( J, ILAST ) - B( J, ILAST ) = -B( J, ILAST ) + H( J, ILAST ) = -H( J, ILAST ) + T( J, ILAST ) = -T( J, ILAST ) 90 CONTINUE ELSE - A( ILAST, ILAST ) = -A( ILAST, ILAST ) - B( ILAST, ILAST ) = -B( ILAST, ILAST ) + H( ILAST, ILAST ) = -H( ILAST, ILAST ) + T( ILAST, ILAST ) = -T( ILAST, ILAST ) END IF IF( ILZ ) THEN DO 100 J = 1, N @@ -582,9 +584,9 @@ 100 CONTINUE END IF END IF - ALPHAR( ILAST ) = A( ILAST, ILAST ) + ALPHAR( ILAST ) = H( ILAST, ILAST ) ALPHAI( ILAST ) = ZERO - BETA( ILAST ) = B( ILAST, ILAST ) + BETA( ILAST ) = T( ILAST, ILAST ) * * Go to next block -- exit if finished. * @@ -617,7 +619,7 @@ * Compute single shifts. * * At this point, IFIRST < ILAST, and the diagonal elements of -* B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in +* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in * magnitude) * IF( ( IITER / 10 )*10.EQ.IITER ) THEN @@ -625,10 +627,10 @@ * Exceptional shift. Chosen for no particularly good reason. * (Single shift only.) * - IF( ( DBLE( MAXIT )*SAFMIN )*ABS( A( ILAST-1, ILAST ) ).LT. - $ ABS( B( ILAST-1, ILAST-1 ) ) ) THEN - ESHIFT = ESHIFT + A( ILAST-1, ILAST ) / - $ B( ILAST-1, ILAST-1 ) + IF( ( DBLE( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT. + $ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN + ESHIFT = ESHIFT + H( ILAST-1, ILAST ) / + $ T( ILAST-1, ILAST-1 ) ELSE ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) ) END IF @@ -641,8 +643,8 @@ * bottom-right 2x2 block of A and B. The first eigenvalue * returned by DLAG2 is the Wilkinson shift (AEP p.512), * - CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA, - $ B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, + CALL DLAG2( H( ILAST-1, ILAST-1 ), LDH, + $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ S2, WR, WR2, WI ) * TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) ) @@ -669,14 +671,14 @@ * DO 120 J = ILAST - 1, IFIRST + 1, -1 ISTART = J - TEMP = ABS( S1*A( J, J-1 ) ) - TEMP2 = ABS( S1*A( J, J )-WR*B( J, J ) ) + TEMP = ABS( S1*H( J, J-1 ) ) + TEMP2 = ABS( S1*H( J, J )-WR*T( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( ABS( ( ASCALE*A( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* + IF( ABS( ( ASCALE*H( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* $ TEMP2 )GO TO 130 120 CONTINUE * @@ -687,26 +689,26 @@ * * Initial Q * - TEMP = S1*A( ISTART, ISTART ) - WR*B( ISTART, ISTART ) - TEMP2 = S1*A( ISTART+1, ISTART ) + TEMP = S1*H( ISTART, ISTART ) - WR*T( ISTART, ISTART ) + TEMP2 = S1*H( ISTART+1, ISTART ) CALL DLARTG( TEMP, TEMP2, C, S, TEMPR ) * * Sweep * DO 190 J = ISTART, ILAST - 1 IF( J.GT.ISTART ) THEN - TEMP = A( J, J-1 ) - CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = ZERO + TEMP = H( J, J-1 ) + CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO END IF * DO 140 JC = J, ILASTM - TEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = TEMP - TEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = TEMP2 + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 140 CONTINUE IF( ILQ ) THEN DO 150 JR = 1, N @@ -716,19 +718,19 @@ 150 CONTINUE END IF * - TEMP = B( J+1, J+1 ) - CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = ZERO + TEMP = T( J+1, J+1 ) + CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO * DO 160 JR = IFRSTM, MIN( J+2, ILAST ) - TEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = TEMP + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP 160 CONTINUE DO 170 JR = IFRSTM, J - TEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = TEMP + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP 170 CONTINUE IF( ILZ ) THEN DO 180 JR = 1, N @@ -759,8 +761,8 @@ * B = ( ) with B11 non-negative. * ( 0 B22 ) * - CALL DLASV2( B( ILAST-1, ILAST-1 ), B( ILAST-1, ILAST ), - $ B( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) + CALL DLASV2( T( ILAST-1, ILAST-1 ), T( ILAST-1, ILAST ), + $ T( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) * IF( B11.LT.ZERO ) THEN CR = -CR @@ -769,17 +771,17 @@ B22 = -B22 END IF * - CALL DROT( ILASTM+1-IFIRST, A( ILAST-1, ILAST-1 ), LDA, - $ A( ILAST, ILAST-1 ), LDA, CL, SL ) - CALL DROT( ILAST+1-IFRSTM, A( IFRSTM, ILAST-1 ), 1, - $ A( IFRSTM, ILAST ), 1, CR, SR ) + CALL DROT( ILASTM+1-IFIRST, H( ILAST-1, ILAST-1 ), LDH, + $ H( ILAST, ILAST-1 ), LDH, CL, SL ) + CALL DROT( ILAST+1-IFRSTM, H( IFRSTM, ILAST-1 ), 1, + $ H( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILAST.LT.ILASTM ) - $ CALL DROT( ILASTM-ILAST, B( ILAST-1, ILAST+1 ), LDB, - $ B( ILAST, ILAST+1 ), LDA, CL, SL ) + $ CALL DROT( ILASTM-ILAST, T( ILAST-1, ILAST+1 ), LDT, + $ T( ILAST, ILAST+1 ), LDH, CL, SL ) IF( IFRSTM.LT.ILAST-1 ) - $ CALL DROT( IFIRST-IFRSTM, B( IFRSTM, ILAST-1 ), 1, - $ B( IFRSTM, ILAST ), 1, CR, SR ) + $ CALL DROT( IFIRST-IFRSTM, T( IFRSTM, ILAST-1 ), 1, + $ T( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILQ ) $ CALL DROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL, @@ -788,17 +790,17 @@ $ CALL DROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR, $ SR ) * - B( ILAST-1, ILAST-1 ) = B11 - B( ILAST-1, ILAST ) = ZERO - B( ILAST, ILAST-1 ) = ZERO - B( ILAST, ILAST ) = B22 + T( ILAST-1, ILAST-1 ) = B11 + T( ILAST-1, ILAST ) = ZERO + T( ILAST, ILAST-1 ) = ZERO + T( ILAST, ILAST ) = B22 * * If B22 is negative, negate column ILAST * IF( B22.LT.ZERO ) THEN DO 210 J = IFRSTM, ILAST - A( J, ILAST ) = -A( J, ILAST ) - B( J, ILAST ) = -B( J, ILAST ) + H( J, ILAST ) = -H( J, ILAST ) + T( J, ILAST ) = -T( J, ILAST ) 210 CONTINUE * IF( ILZ ) THEN @@ -812,8 +814,8 @@ * * Recompute shift * - CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA, - $ B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, + CALL DLAG2( H( ILAST-1, ILAST-1 ), LDH, + $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ TEMP, WR, TEMP2, WI ) * * If standardization has perturbed the shift onto real line, @@ -825,10 +827,10 @@ * * Do EISPACK (QZVAL) computation of alpha and beta * - A11 = A( ILAST-1, ILAST-1 ) - A21 = A( ILAST, ILAST-1 ) - A12 = A( ILAST-1, ILAST ) - A22 = A( ILAST, ILAST ) + A11 = H( ILAST-1, ILAST-1 ) + A21 = H( ILAST, ILAST-1 ) + A12 = H( ILAST-1, ILAST ) + A22 = H( ILAST, ILAST ) * * Compute complex Givens rotation on right * (Assume some element of C = (sA - wB) > unfl ) @@ -845,10 +847,10 @@ * IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ $ ABS( C22R )+ABS( C22I ) ) THEN - T = DLAPY3( C12, C11R, C11I ) - CZ = C12 / T - SZR = -C11R / T - SZI = -C11I / T + T1 = DLAPY3( C12, C11R, C11I ) + CZ = C12 / T1 + SZR = -C11R / T1 + SZI = -C11I / T1 ELSE CZ = DLAPY2( C22R, C22I ) IF( CZ.LE.SAFMIN ) THEN @@ -858,10 +860,10 @@ ELSE TEMPR = C22R / CZ TEMPI = C22I / CZ - T = DLAPY2( CZ, C21 ) - CZ = CZ / T - SZR = -C21*TEMPR / T - SZI = C21*TEMPI / T + T1 = DLAPY2( CZ, C21 ) + CZ = CZ / T1 + SZR = -C21*TEMPR / T1 + SZI = C21*TEMPI / T1 END IF END IF * @@ -895,10 +897,10 @@ SQI = TEMPI*A2R - TEMPR*A2I END IF END IF - T = DLAPY3( CQ, SQR, SQI ) - CQ = CQ / T - SQR = SQR / T - SQI = SQI / T + T1 = DLAPY3( CQ, SQR, SQI ) + CQ = CQ / T1 + SQR = SQR / T1 + SQI = SQI / T1 * * Compute diagonal elements of QBZ * @@ -950,26 +952,26 @@ * * We assume that the block is at least 3x3 * - AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD22 = ( ASCALE*A( ILAST, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - U12 = B( ILAST-1, ILAST ) / B( ILAST, ILAST ) - AD11L = ( ASCALE*A( IFIRST, IFIRST ) ) / - $ ( BSCALE*B( IFIRST, IFIRST ) ) - AD21L = ( ASCALE*A( IFIRST+1, IFIRST ) ) / - $ ( BSCALE*B( IFIRST, IFIRST ) ) - AD12L = ( ASCALE*A( IFIRST, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - AD22L = ( ASCALE*A( IFIRST+1, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - AD32L = ( ASCALE*A( IFIRST+2, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - U12L = B( IFIRST, IFIRST+1 ) / B( IFIRST+1, IFIRST+1 ) + AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD22 = ( ASCALE*H( ILAST, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) + AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) * V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L @@ -991,27 +993,27 @@ * Zero (j-1)st column of A * IF( J.GT.ISTART ) THEN - V( 1 ) = A( J, J-1 ) - V( 2 ) = A( J+1, J-1 ) - V( 3 ) = A( J+2, J-1 ) + V( 1 ) = H( J, J-1 ) + V( 2 ) = H( J+1, J-1 ) + V( 3 ) = H( J+2, J-1 ) * - CALL DLARFG( 3, A( J, J-1 ), V( 2 ), 1, TAU ) + CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE - A( J+1, J-1 ) = ZERO - A( J+2, J-1 ) = ZERO + H( J+1, J-1 ) = ZERO + H( J+2, J-1 ) = ZERO END IF * DO 230 JC = J, ILASTM - TEMP = TAU*( A( J, JC )+V( 2 )*A( J+1, JC )+V( 3 )* - $ A( J+2, JC ) ) - A( J, JC ) = A( J, JC ) - TEMP - A( J+1, JC ) = A( J+1, JC ) - TEMP*V( 2 ) - A( J+2, JC ) = A( J+2, JC ) - TEMP*V( 3 ) - TEMP2 = TAU*( B( J, JC )+V( 2 )*B( J+1, JC )+V( 3 )* - $ B( J+2, JC ) ) - B( J, JC ) = B( J, JC ) - TEMP2 - B( J+1, JC ) = B( J+1, JC ) - TEMP2*V( 2 ) - B( J+2, JC ) = B( J+2, JC ) - TEMP2*V( 3 ) + TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* + $ H( J+2, JC ) ) + H( J, JC ) = H( J, JC ) - TEMP + H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) + H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) + TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* + $ T( J+2, JC ) ) + T( J, JC ) = T( J, JC ) - TEMP2 + T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) + T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) 230 CONTINUE IF( ILQ ) THEN DO 240 JR = 1, N @@ -1028,27 +1030,27 @@ * Swap rows to pivot * ILPIVT = .FALSE. - TEMP = MAX( ABS( B( J+1, J+1 ) ), ABS( B( J+1, J+2 ) ) ) - TEMP2 = MAX( ABS( B( J+2, J+1 ) ), ABS( B( J+2, J+2 ) ) ) + TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) + TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN SCALE = ZERO U1 = ONE U2 = ZERO GO TO 250 ELSE IF( TEMP.GE.TEMP2 ) THEN - W11 = B( J+1, J+1 ) - W21 = B( J+2, J+1 ) - W12 = B( J+1, J+2 ) - W22 = B( J+2, J+2 ) - U1 = B( J+1, J ) - U2 = B( J+2, J ) + W11 = T( J+1, J+1 ) + W21 = T( J+2, J+1 ) + W12 = T( J+1, J+2 ) + W22 = T( J+2, J+2 ) + U1 = T( J+1, J ) + U2 = T( J+2, J ) ELSE - W21 = B( J+1, J+1 ) - W11 = B( J+2, J+1 ) - W22 = B( J+1, J+2 ) - W12 = B( J+2, J+2 ) - U2 = B( J+1, J ) - U1 = B( J+2, J ) + W21 = T( J+1, J+1 ) + W11 = T( J+2, J+1 ) + W22 = T( J+1, J+2 ) + W12 = T( J+2, J+2 ) + U2 = T( J+1, J ) + U1 = T( J+2, J ) END IF * * Swap columns if nec. @@ -1098,9 +1100,9 @@ * * Compute Householder Vector * - T = SQRT( SCALE**2+U1**2+U2**2 ) - TAU = ONE + SCALE / T - VS = -ONE / ( SCALE+T ) + T1 = SQRT( SCALE**2+U1**2+U2**2 ) + TAU = ONE + SCALE / T1 + VS = -ONE / ( SCALE+T1 ) V( 1 ) = ONE V( 2 ) = VS*U1 V( 3 ) = VS*U2 @@ -1108,18 +1110,18 @@ * Apply transformations from the right. * DO 260 JR = IFRSTM, MIN( J+3, ILAST ) - TEMP = TAU*( A( JR, J )+V( 2 )*A( JR, J+1 )+V( 3 )* - $ A( JR, J+2 ) ) - A( JR, J ) = A( JR, J ) - TEMP - A( JR, J+1 ) = A( JR, J+1 ) - TEMP*V( 2 ) - A( JR, J+2 ) = A( JR, J+2 ) - TEMP*V( 3 ) + TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* + $ H( JR, J+2 ) ) + H( JR, J ) = H( JR, J ) - TEMP + H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) + H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) 260 CONTINUE DO 270 JR = IFRSTM, J + 2 - TEMP = TAU*( B( JR, J )+V( 2 )*B( JR, J+1 )+V( 3 )* - $ B( JR, J+2 ) ) - B( JR, J ) = B( JR, J ) - TEMP - B( JR, J+1 ) = B( JR, J+1 ) - TEMP*V( 2 ) - B( JR, J+2 ) = B( JR, J+2 ) - TEMP*V( 3 ) + TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* + $ T( JR, J+2 ) ) + T( JR, J ) = T( JR, J ) - TEMP + T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) + T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) 270 CONTINUE IF( ILZ ) THEN DO 280 JR = 1, N @@ -1130,8 +1132,8 @@ Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) 280 CONTINUE END IF - B( J+1, J ) = ZERO - B( J+2, J ) = ZERO + T( J+1, J ) = ZERO + T( J+2, J ) = ZERO 290 CONTINUE * * Last elements: Use Givens rotations @@ -1139,17 +1141,17 @@ * Rotations from the left * J = ILAST - 1 - TEMP = A( J, J-1 ) - CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = ZERO + TEMP = H( J, J-1 ) + CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO * DO 300 JC = J, ILASTM - TEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = TEMP - TEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = TEMP2 + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 300 CONTINUE IF( ILQ ) THEN DO 310 JR = 1, N @@ -1161,19 +1163,19 @@ * * Rotations from the right. * - TEMP = B( J+1, J+1 ) - CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = ZERO + TEMP = T( J+1, J+1 ) + CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO * DO 320 JR = IFRSTM, ILAST - TEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = TEMP + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP 320 CONTINUE DO 330 JR = IFRSTM, ILAST - 1 - TEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = TEMP + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP 330 CONTINUE IF( ILZ ) THEN DO 340 JR = 1, N @@ -1207,15 +1209,15 @@ * Set Eigenvalues 1:ILO-1 * DO 410 J = 1, ILO - 1 - IF( B( J, J ).LT.ZERO ) THEN + IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 390 JR = 1, J - A( JR, J ) = -A( JR, J ) - B( JR, J ) = -B( JR, J ) + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) 390 CONTINUE ELSE - A( J, J ) = -A( J, J ) - B( J, J ) = -B( J, J ) + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 400 JR = 1, N @@ -1223,9 +1225,9 @@ 400 CONTINUE END IF END IF - ALPHAR( J ) = A( J, J ) + ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO - BETA( J ) = B( J, J ) + BETA( J ) = T( J, J ) 410 CONTINUE * * Normal Termination diff -uNr LAPACK.orig/SRC/dlasr.f LAPACK/SRC/dlasr.f --- LAPACK.orig/SRC/dlasr.f Thu Nov 4 14:24:50 1999 +++ LAPACK/SRC/dlasr.f Fri May 25 16:12:31 2001 @@ -3,7 +3,7 @@ * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* May 3, 2001 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE @@ -16,44 +16,77 @@ * Purpose * ======= * -* DLASR performs the transformation -* -* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) -* -* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) -* -* where A is an m by n real matrix and P is an orthogonal matrix, -* consisting of a sequence of plane rotations determined by the -* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' -* and z = n when SIDE = 'R' or 'r' ): -* -* When DIRECT = 'F' or 'f' ( Forward sequence ) then -* -* P = P( z - 1 )*...*P( 2 )*P( 1 ), -* -* and when DIRECT = 'B' or 'b' ( Backward sequence ) then -* -* P = P( 1 )*P( 2 )*...*P( z - 1 ), -* -* where P( k ) is a plane rotation matrix for the following planes: -* -* when PIVOT = 'V' or 'v' ( Variable pivot ), -* the plane ( k, k + 1 ) -* -* when PIVOT = 'T' or 't' ( Top pivot ), -* the plane ( 1, k + 1 ) -* -* when PIVOT = 'B' or 'b' ( Bottom pivot ), -* the plane ( k, z ) -* -* c( k ) and s( k ) must contain the cosine and sine that define the -* matrix P( k ). The two by two plane rotation part of the matrix -* P( k ), R( k ), is assumed to be of the form -* -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) -* -* This version vectorises across rows of the array A when SIDE = 'L'. +* DLASR applies a sequence of plane rotations to a real 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 * ========= @@ -62,13 +95,13 @@ * 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' +* = 'R': Right, compute A:= A*P**T * * 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 ) +* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) +* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation @@ -85,18 +118,22 @@ * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * -* C, S (input) DOUBLE PRECISION arrays, dimension +* 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' -* c(k) and s(k) contain the cosine and sine that define the -* matrix P(k). The two by two plane rotation part of the -* matrix P(k), R(k), is assumed to be of the form -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) +* 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) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. On exit, A is overwritten by P*A if -* SIDE = 'R' or by A*P' if SIDE = 'L'. +* 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). diff -uNr LAPACK.orig/SRC/dsbgst.f LAPACK/SRC/dsbgst.f --- LAPACK.orig/SRC/dsbgst.f Thu Nov 4 14:23:31 1999 +++ LAPACK/SRC/dsbgst.f Fri May 25 16:12:50 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* January 9, 2001 * * .. Scalar Arguments .. CHARACTER UPLO, VECT @@ -125,7 +125,7 @@ INFO = -3 ELSE IF( KA.LT.0 ) THEN INFO = -4 - ELSE IF( KB.LT.0 ) THEN + ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN INFO = -5 ELSE IF( LDAB.LT.KA+1 ) THEN INFO = -7 diff -uNr LAPACK.orig/SRC/dstebz.f LAPACK/SRC/dstebz.f --- LAPACK.orig/SRC/dstebz.f Thu Nov 4 14:24:57 1999 +++ LAPACK/SRC/dstebz.f Fri May 25 16:13:23 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-18-00: Increase FUDGE factor for T3E (eca) * * .. Scalar Arguments .. CHARACTER ORDER, RANGE @@ -175,7 +176,7 @@ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ HALF = 1.0D0 / TWO ) DOUBLE PRECISION FUDGE, RELFAC - PARAMETER ( FUDGE = 2.0D0, RELFAC = 2.0D0 ) + PARAMETER ( FUDGE = 2.1D0, RELFAC = 2.0D0 ) * .. * .. Local Scalars .. LOGICAL NCNVRG, TOOFEW diff -uNr LAPACK.orig/SRC/dtgevc.f LAPACK/SRC/dtgevc.f --- LAPACK.orig/SRC/dtgevc.f Thu Nov 4 14:26:09 1999 +++ LAPACK/SRC/dtgevc.f Fri May 25 16:13:33 2001 @@ -1,18 +1,18 @@ - SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, + SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 4, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE - INTEGER INFO, LDA, LDB, LDVL, LDVR, M, MM, N + INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), VL( LDVL, * ), + DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * @@ -20,35 +20,31 @@ * Purpose * ======= * -* DTGEVC computes some or all of the right and/or left generalized -* eigenvectors of a pair of real upper triangular matrices (A,B). -* -* The right generalized eigenvector x and the left generalized -* eigenvector y of (A,B) corresponding to a generalized eigenvalue -* w are defined by: -* -* (A - wB) * x = 0 and y**H * (A - wB) = 0 -* +* DTGEVC computes some or all of the right and/or left eigenvectors of +* a pair of real matrices (S,P), where S is a quasi-triangular matrix +* and P is upper triangular. Matrix pairs of this type are produced by +* the generalized Schur factorization of a matrix pair (A,B): +* +* A = Q*S*Z**T, B = Q*P*Z**T +* +* as computed by DGGHRD + DHGEQZ. +* +* The right eigenvector x and the left eigenvector y of (S,P) +* corresponding to an eigenvalue w are defined by: +* +* S*x = w*P*x, (y**H)*S = w*(y**H)*P, +* * where y**H denotes the conjugate tranpose of y. -* -* If an eigenvalue w is determined by zero diagonal elements of both A -* and B, a unit vector is returned as the corresponding eigenvector. -* -* If all eigenvectors are requested, the routine may either return -* the matrices X and/or Y of right or left eigenvectors of (A,B), or -* the products Z*X and/or Q*Y, where Z and Q are input orthogonal -* matrices. If (A,B) was obtained from the generalized real-Schur -* factorization of an original pair of matrices -* (A0,B0) = (Q*A*Z**H,Q*B*Z**H), -* then Z*X and Q*Y are the matrices of right or left eigenvectors of -* A. -* -* A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal -* blocks. Corresponding to each 2-by-2 diagonal block is a complex -* conjugate pair of eigenvalues and eigenvectors; only one -* eigenvector of the pair is computed, namely the one corresponding -* to the eigenvalue with positive imaginary part. -* +* The eigenvalues are not input to this routine, but are computed +* directly from the diagonal blocks of S and P. +* +* This routine returns the matrices X and/or Y of right and left +* eigenvectors of (S,P), or the products Z*X and/or Q*Y, +* where Z and Q are input matrices. +* If Q and Z are the orthogonal factors from the generalized Schur +* factorization of a matrix pair (A,B), then Z*X and Q*Y +* are the matrices of right and left eigenvectors of (A,B). +* * Arguments * ========= * @@ -59,78 +55,84 @@ * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; -* = 'B': compute all right and/or left eigenvectors, and -* backtransform them using the input matrices supplied -* in VR and/or VL; +* = 'B': compute all right and/or left eigenvectors, +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY='S', SELECT specifies the eigenvectors to be -* computed. -* If HOWMNY='A' or 'B', SELECT is not referenced. -* To select the real eigenvector corresponding to the real -* eigenvalue w(j), SELECT(j) must be set to .TRUE. To select -* the complex eigenvector corresponding to a complex conjugate -* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must -* be set to .TRUE.. +* computed. If w(j) is a real eigenvalue, the corresponding +* real eigenvector is computed if SELECT(j) is .TRUE.. +* If w(j) and w(j+1) are the real and imaginary parts of a +* complex eigenvalue, the corresponding complex eigenvector +* is computed if either SELECT(j) or SELECT(j+1) is .TRUE., +* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is +* set to .FALSE.. +* Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER -* The order of the matrices A and B. N >= 0. +* The order of the matrices S and P. N >= 0. * -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The upper quasi-triangular matrix A. +* S (input) DOUBLE PRECISION array, dimension (LDS,N) +* The upper quasi-triangular matrix S from a generalized Schur +* factorization, as computed by DHGEQZ. +* +* LDS (input) INTEGER +* The leading dimension of array S. LDS >= max(1,N). +* +* P (input) DOUBLE PRECISION array, dimension (LDP,N) +* The upper triangular matrix P from a generalized Schur +* factorization, as computed by DHGEQZ. +* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks +* of S must be in positive diagonal form. * -* LDA (input) INTEGER -* The leading dimension of array A. LDA >= max(1, N). -* -* B (input) DOUBLE PRECISION array, dimension (LDB,N) -* The upper triangular matrix B. If A has a 2-by-2 diagonal -* block, then the corresponding 2-by-2 block of B must be -* diagonal with positive elements. -* -* LDB (input) INTEGER -* The leading dimension of array B. LDB >= max(1,N). +* LDP (input) INTEGER +* The leading dimension of array P. LDP >= max(1,N). * * VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of left Schur vectors returned by DHGEQZ). * On exit, if SIDE = 'L' or 'B', VL contains: -* if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Q*Y; -* if HOWMNY = 'S', the left eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VL, in the same order as their eigenvalues. -* If SIDE = 'R', VL is not referenced. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. * +* Not referenced if SIDE = 'R'. +* * LDVL (input) INTEGER -* The leading dimension of array VL. -* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must -* contain an N-by-N matrix Q (usually the orthogonal matrix Z +* contain an N-by-N matrix Z (usually the orthogonal matrix Z * of right Schur vectors returned by DHGEQZ). +* * On exit, if SIDE = 'R' or 'B', VR contains: -* if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); -* if HOWMNY = 'B', the matrix Z*X; -* if HOWMNY = 'S', the right eigenvectors of (A,B) specified by -* SELECT, stored consecutively in the columns of -* VR, in the same order as their eigenvalues. -* If SIDE = 'L', VR is not referenced. +* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); +* if HOWMNY = 'B' or 'b', the matrix Z*X; +* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) +* specified by SELECT, stored consecutively in the +* columns of VR, in the same order as their +* eigenvalues. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. +* +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. -* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. @@ -199,7 +201,7 @@ * partial sums. Since FORTRAN arrays are stored columnwise, this has * the advantage that at each step, the elements of C that are accessed * are adjacent to one another, whereas with the rowwise method, the -* elements accessed at a step are spaced LDA (and LDB) words apart. +* elements accessed at a step are spaced LDS (and LDP) words apart. * * When finding left eigenvectors, the matrix in question is the * transpose of the one in storage, so the rowwise method then @@ -226,8 +228,8 @@ $ XSCALE * .. * .. Local Arrays .. - DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMA( 2, 2 ), - $ SUMB( 2, 2 ) + DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ), + $ SUMP( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME @@ -235,7 +237,7 @@ EXTERNAL LSAME, DLAMCH * .. * .. External Subroutines .. - EXTERNAL DGEMV, DLACPY, DLAG2, DLALN2, XERBLA + EXTERNAL DGEMV, DLABAD, DLACPY, DLAG2, DLALN2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN @@ -252,7 +254,7 @@ IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. - ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN + ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. @@ -284,9 +286,9 @@ INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN @@ -305,7 +307,7 @@ GO TO 10 END IF IF( J.LT.N ) THEN - IF( A( J+1, J ).NE.ZERO ) + IF( S( J+1, J ).NE.ZERO ) $ ILCPLX = .TRUE. END IF IF( ILCPLX ) THEN @@ -325,11 +327,11 @@ ILABAD = .FALSE. ILBBAD = .FALSE. DO 20 J = 1, N - 1 - IF( A( J+1, J ).NE.ZERO ) THEN - IF( B( J, J ).EQ.ZERO .OR. B( J+1, J+1 ).EQ.ZERO .OR. - $ B( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. + IF( S( J+1, J ).NE.ZERO ) THEN + IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR. + $ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. IF( J.LT.N-1 ) THEN - IF( A( J+2, J+1 ).NE.ZERO ) + IF( S( J+2, J+1 ).NE.ZERO ) $ ILABAD = .TRUE. END IF END IF @@ -372,30 +374,30 @@ * blocks) of A and B to check for possible overflow in the * triangular solver. * - ANORM = ABS( A( 1, 1 ) ) + ANORM = ABS( S( 1, 1 ) ) IF( N.GT.1 ) - $ ANORM = ANORM + ABS( A( 2, 1 ) ) - BNORM = ABS( B( 1, 1 ) ) + $ ANORM = ANORM + ABS( S( 2, 1 ) ) + BNORM = ABS( P( 1, 1 ) ) WORK( 1 ) = ZERO WORK( N+1 ) = ZERO * DO 50 J = 2, N TEMP = ZERO TEMP2 = ZERO - IF( A( J, J-1 ).EQ.ZERO ) THEN + IF( S( J, J-1 ).EQ.ZERO ) THEN IEND = J - 1 ELSE IEND = J - 2 END IF DO 30 I = 1, IEND - TEMP = TEMP + ABS( A( I, J ) ) - TEMP2 = TEMP2 + ABS( B( I, J ) ) + TEMP = TEMP + ABS( S( I, J ) ) + TEMP2 = TEMP2 + ABS( P( I, J ) ) 30 CONTINUE WORK( J ) = TEMP WORK( N+J ) = TEMP2 DO 40 I = IEND + 1, MIN( J+1, N ) - TEMP = TEMP + ABS( A( I, J ) ) - TEMP2 = TEMP2 + ABS( B( I, J ) ) + TEMP = TEMP + ABS( S( I, J ) ) + TEMP2 = TEMP2 + ABS( P( I, J ) ) 40 CONTINUE ANORM = MAX( ANORM, TEMP ) BNORM = MAX( BNORM, TEMP2 ) @@ -425,7 +427,7 @@ END IF NW = 1 IF( JE.LT.N ) THEN - IF( A( JE+1, JE ).NE.ZERO ) THEN + IF( S( JE+1, JE ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF @@ -444,8 +446,8 @@ * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN - IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN + IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * @@ -472,10 +474,10 @@ * * Real eigenvalue * - TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, - $ ABS( B( JE, JE ) )*BSCALE, SAFMIN ) - SALFAR = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*B( JE, JE ) )*BSCALE + TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, + $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) + SALFAR = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO @@ -517,7 +519,7 @@ * * Complex eigenvalue * - CALL DLAG2( A( JE, JE ), LDA, B( JE, JE ), LDB, + CALL DLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) BCOEFI = -BCOEFI @@ -549,9 +551,9 @@ * * Compute first two components of eigenvector * - TEMP = ACOEF*A( JE+1, JE ) - TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE ) - TEMP2I = -BCOEFI*B( JE, JE ) + TEMP = ACOEF*S( JE+1, JE ) + TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) + TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO @@ -560,10 +562,10 @@ ELSE WORK( 2*N+JE+1 ) = ONE WORK( 3*N+JE+1 ) = ZERO - TEMP = ACOEF*A( JE, JE+1 ) - WORK( 2*N+JE ) = ( BCOEFR*B( JE+1, JE+1 )-ACOEF* - $ A( JE+1, JE+1 ) ) / TEMP - WORK( 3*N+JE ) = BCOEFI*B( JE+1, JE+1 ) / TEMP + TEMP = ACOEF*S( JE, JE+1 ) + WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF* + $ S( JE+1, JE+1 ) ) / TEMP + WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP END IF XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) ) @@ -586,11 +588,11 @@ END IF * NA = 1 - BDIAG( 1 ) = B( J, J ) + BDIAG( 1 ) = P( J, J ) IF( J.LT.N ) THEN - IF( A( J+1, J ).NE.ZERO ) THEN + IF( S( J+1, J ).NE.ZERO ) THEN IL2BY2 = .TRUE. - BDIAG( 2 ) = B( J+1, J+1 ) + BDIAG( 2 ) = P( J+1, J+1 ) NA = 2 END IF END IF @@ -616,13 +618,13 @@ * Compute dot products * * j-1 -* SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) +* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * * To reduce the op count, this is done as * * _ j-1 _ j-1 -* a*conjg( sum A(k,j)*x(k) ) - b*conjg( sum B(k,j)*x(k) ) +* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) * k=je k=je * * which may cause underflow problems if A or B are close @@ -659,15 +661,15 @@ *$PL$ CMCHAR='*' * DO 110 JA = 1, NA - SUMA( JA, JW ) = ZERO - SUMB( JA, JW ) = ZERO + SUMS( JA, JW ) = ZERO + SUMP( JA, JW ) = ZERO * DO 100 JR = JE, J - 1 - SUMA( JA, JW ) = SUMA( JA, JW ) + - $ A( JR, J+JA-1 )* + SUMS( JA, JW ) = SUMS( JA, JW ) + + $ S( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) - SUMB( JA, JW ) = SUMB( JA, JW ) + - $ B( JR, J+JA-1 )* + SUMP( JA, JW ) = SUMP( JA, JW ) + + $ P( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) 100 CONTINUE 110 CONTINUE @@ -687,15 +689,15 @@ * DO 130 JA = 1, NA IF( ILCPLX ) THEN - SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + - $ BCOEFR*SUMB( JA, 1 ) - - $ BCOEFI*SUMB( JA, 2 ) - SUM( JA, 2 ) = -ACOEF*SUMA( JA, 2 ) + - $ BCOEFR*SUMB( JA, 2 ) + - $ BCOEFI*SUMB( JA, 1 ) + SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + + $ BCOEFR*SUMP( JA, 1 ) - + $ BCOEFI*SUMP( JA, 2 ) + SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) + + $ BCOEFR*SUMP( JA, 2 ) + + $ BCOEFI*SUMP( JA, 1 ) ELSE - SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + - $ BCOEFR*SUMB( JA, 1 ) + SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + + $ BCOEFR*SUMP( JA, 1 ) END IF 130 CONTINUE * @@ -703,7 +705,7 @@ * Solve ( a A - b B ) y = SUM(,) * with scaling and perturbation of the denominator * - CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, A( J, J ), LDA, + CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS, $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR, $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP, $ IINFO ) @@ -790,7 +792,7 @@ END IF NW = 1 IF( JE.GT.1 ) THEN - IF( A( JE, JE-1 ).NE.ZERO ) THEN + IF( S( JE, JE-1 ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF @@ -809,8 +811,8 @@ * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN - IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN + IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- unit eigenvector * @@ -839,10 +841,10 @@ * * Real eigenvalue * - TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, - $ ABS( B( JE, JE ) )*BSCALE, SAFMIN ) - SALFAR = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*B( JE, JE ) )*BSCALE + TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, + $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) + SALFAR = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO @@ -885,14 +887,14 @@ * (See "Further Details", above.) * DO 260 JR = 1, JE - 1 - WORK( 2*N+JR ) = BCOEFR*B( JR, JE ) - - $ ACOEF*A( JR, JE ) + WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) - + $ ACOEF*S( JR, JE ) 260 CONTINUE ELSE * * Complex eigenvalue * - CALL DLAG2( A( JE-1, JE-1 ), LDA, B( JE-1, JE-1 ), LDB, + CALL DLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) IF( BCOEFI.EQ.ZERO ) THEN @@ -924,9 +926,9 @@ * Compute first two components of eigenvector * and contribution to sums * - TEMP = ACOEF*A( JE, JE-1 ) - TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE ) - TEMP2I = -BCOEFI*B( JE, JE ) + TEMP = ACOEF*S( JE, JE-1 ) + TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) + TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO @@ -935,10 +937,10 @@ ELSE WORK( 2*N+JE-1 ) = ONE WORK( 3*N+JE-1 ) = ZERO - TEMP = ACOEF*A( JE-1, JE ) - WORK( 2*N+JE ) = ( BCOEFR*B( JE-1, JE-1 )-ACOEF* - $ A( JE-1, JE-1 ) ) / TEMP - WORK( 3*N+JE ) = BCOEFI*B( JE-1, JE-1 ) / TEMP + TEMP = ACOEF*S( JE-1, JE ) + WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF* + $ S( JE-1, JE-1 ) ) / TEMP + WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP END IF * XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), @@ -958,12 +960,12 @@ CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE ) CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE ) DO 270 JR = 1, JE - 2 - WORK( 2*N+JR ) = -CREALA*A( JR, JE-1 ) + - $ CREALB*B( JR, JE-1 ) - - $ CRE2A*A( JR, JE ) + CRE2B*B( JR, JE ) - WORK( 3*N+JR ) = -CIMAGA*A( JR, JE-1 ) + - $ CIMAGB*B( JR, JE-1 ) - - $ CIM2A*A( JR, JE ) + CIM2B*B( JR, JE ) + WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) + + $ CREALB*P( JR, JE-1 ) - + $ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE ) + WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) + + $ CIMAGB*P( JR, JE-1 ) - + $ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE ) 270 CONTINUE END IF * @@ -978,23 +980,23 @@ * next iteration to process it (when it will be j:j+1) * IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN - IF( A( J, J-1 ).NE.ZERO ) THEN + IF( S( J, J-1 ).NE.ZERO ) THEN IL2BY2 = .TRUE. GO TO 370 END IF END IF - BDIAG( 1 ) = B( J, J ) + BDIAG( 1 ) = P( J, J ) IF( IL2BY2 ) THEN NA = 2 - BDIAG( 2 ) = B( J+1, J+1 ) + BDIAG( 2 ) = P( J+1, J+1 ) ELSE NA = 1 END IF * * Compute x(j) (and x(j+1), if 2-by-2 block) * - CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, A( J, J ), - $ LDA, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), + CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ), + $ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN @@ -1014,7 +1016,7 @@ 300 CONTINUE 310 CONTINUE * -* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling +* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( J.GT.1 ) THEN * @@ -1052,19 +1054,19 @@ $ BCOEFR*WORK( 3*N+J+JA-1 ) DO 340 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - - $ CREALA*A( JR, J+JA-1 ) + - $ CREALB*B( JR, J+JA-1 ) + $ CREALA*S( JR, J+JA-1 ) + + $ CREALB*P( JR, J+JA-1 ) WORK( 3*N+JR ) = WORK( 3*N+JR ) - - $ CIMAGA*A( JR, J+JA-1 ) + - $ CIMAGB*B( JR, J+JA-1 ) + $ CIMAGA*S( JR, J+JA-1 ) + + $ CIMAGB*P( JR, J+JA-1 ) 340 CONTINUE ELSE CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) DO 350 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - - $ CREALA*A( JR, J+JA-1 ) + - $ CREALB*B( JR, J+JA-1 ) + $ CREALA*S( JR, J+JA-1 ) + + $ CREALB*P( JR, J+JA-1 ) 350 CONTINUE END IF 360 CONTINUE diff -uNr LAPACK.orig/SRC/dtrevc.f LAPACK/SRC/dtrevc.f --- LAPACK.orig/SRC/dtrevc.f Thu Nov 4 14:24:59 1999 +++ LAPACK/SRC/dtrevc.f Fri May 25 16:13:52 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 7, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -21,28 +21,23 @@ * * DTREVC computes some or all of the right and/or left eigenvectors of * a real upper quasi-triangular matrix T. -* +* Matrices of this type are produced by the Schur factorization of +* a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. +* * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: -* -* T*x = w*x, y'*T = w*y' -* -* where y' denotes the conjugate transpose of the vector y. -* -* If all eigenvectors are requested, the routine may either return the -* matrices X and/or Y of right or left eigenvectors of T, or the -* products Q*X and/or Q*Y, where Q is an input orthogonal -* matrix. If T was obtained from the real-Schur factorization of an -* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of -* right or left eigenvectors of A. -* -* T must be in Schur canonical form (as returned by DHSEQR), that is, -* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each -* 2-by-2 diagonal block has its diagonal elements equal and its -* off-diagonal elements of opposite sign. Corresponding to each 2-by-2 -* diagonal block is a complex conjugate pair of eigenvalues and -* eigenvectors; only one eigenvector of the pair is computed, namely -* the one corresponding to the eigenvalue with positive imaginary part. +* +* T*x = w*x, (y**H)*T = w*(y**H) +* +* where y**H denotes the conjugate transpose of y. +* The eigenvalues are not input to this routine, but are read directly +* from the diagonal blocks 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 orthogonal 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 * ========= @@ -55,21 +50,21 @@ * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, -* and backtransform them using the input matrices -* supplied in VR and/or VL; +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, -* specified by the logical array SELECT. +* as indicated by the logical array SELECT. * * SELECT (input/output) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. -* If HOWMNY = 'A' or 'B', SELECT is not referenced. -* To select the real eigenvector corresponding to a real -* eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select -* the complex eigenvector corresponding to a complex conjugate -* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be -* set to .TRUE.; then on exit SELECT(j) is .TRUE. and -* SELECT(j+1) is .FALSE.. +* If w(j) is a real eigenvalue, the corresponding real +* eigenvector is computed if SELECT(j) is .TRUE.. +* If w(j) and w(j+1) are the real and imaginary parts of a +* complex eigenvalue, the corresponding complex eigenvector is +* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and +* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to +* .FALSE.. +* Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER * The order of the matrix T. N >= 0. @@ -86,15 +81,6 @@ * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; -* VL has the same quasi-lower triangular form -* as T'. If T(i,i) is a real eigenvalue, then -* the i-th column VL(i) of VL is its -* corresponding eigenvector. If T(i:i+1,i:i+1) -* is a 2-by-2 block whose eigenvalues are -* complex-conjugate eigenvalues of T, then -* VL(i)+sqrt(-1)*VL(i+1) is the complex -* eigenvector corresponding to the eigenvalue -* with positive real part. * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns @@ -103,11 +89,11 @@ * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of the array VL. LDVL >= max(1,N) if -* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of the array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must @@ -115,15 +101,6 @@ * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; -* VR has the same quasi-upper triangular form -* as T. If T(i,i) is a real eigenvalue, then -* the i-th column VR(i) of VR is its -* corresponding eigenvector. If T(i:i+1,i:i+1) -* is a 2-by-2 block whose eigenvalues are -* complex-conjugate eigenvalues of T, then -* VR(i)+sqrt(-1)*VR(i+1) is the complex -* eigenvector corresponding to the eigenvalue -* with positive real part. * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns @@ -132,11 +109,11 @@ * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. LDVR >= max(1,N) if -* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. diff -uNr LAPACK.orig/SRC/dtrsen.f LAPACK/SRC/dtrsen.f --- LAPACK.orig/SRC/dtrsen.f Thu Nov 4 14:24:59 1999 +++ LAPACK/SRC/dtrsen.f Fri May 25 16:14:10 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* January 3, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB @@ -118,8 +118,8 @@ * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= max(1,N); -* if JOB = 'E', LWORK >= M*(N-M); -* if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). +* if JOB = 'E', LWORK >= max(1,M*(N-M)); +* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns @@ -127,12 +127,12 @@ * message related to LWORK is issued by XERBLA. * * IWORK (workspace) INTEGER array, dimension (LIWORK) -* IF JOB = 'N' or 'E', IWORK is not referenced. +* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. * * LIWORK (input) INTEGER * The dimension of the array IWORK. * If JOB = 'N' or 'E', LIWORK >= 1; -* if JOB = 'V' or 'B', LIWORK >= M*(N-M). +* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). * * If LIWORK = -1, then a workspace query is assumed; the * routine only calculates the optimal size of the IWORK array, diff -uNr LAPACK.orig/SRC/sbdsqr.f LAPACK/SRC/sbdsqr.f --- LAPACK.orig/SRC/sbdsqr.f Thu Nov 4 14:25:42 1999 +++ LAPACK/SRC/sbdsqr.f Fri May 25 15:58:54 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. CHARACTER UPLO @@ -18,14 +18,26 @@ * Purpose * ======= * -* SBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. -* -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given real input matrices U, VT, and C. +* SBDSQR 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**T +* +* 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**T*VT instead of +* P**T, for given real input matrices U and VT. When U and VT are the +* orthogonal matrices that reduce a general matrix A to bidiagonal +* form: A = U*B*VT, as computed by SGEBRD, then +* +* A = (U*Q) * S * (P**T*VT) +* +* is the SVD of A. Optionally, the subroutine may also compute Q**T*C +* for a given real input matrix C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, @@ -61,18 +73,17 @@ * order. * * E (input/output) REAL array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E +* 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. E(N) is used for workspace. * * VT (input/output) REAL array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. +* On exit, VT is overwritten by P**T * VT. +* Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. @@ -81,21 +92,22 @@ * U (input/output) REAL array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. -* U is not referenced if NRU = 0. +* Not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) REAL array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. -* On exit, C is overwritten by Q' * C. -* C is not referenced if NCC = 0. +* On exit, C is overwritten by Q**T * 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. * -* WORK (workspace) REAL array, dimension (4*N) +* WORK (workspace) REAL array, dimension (2*N) +* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise * * INFO (output) INTEGER * = 0: successful exit diff -uNr LAPACK.orig/SRC/sgebd2.f LAPACK/SRC/sgebd2.f --- LAPACK.orig/SRC/sgebd2.f Thu Nov 4 14:23:33 1999 +++ LAPACK/SRC/sgebd2.f Fri May 25 15:59:24 2001 @@ -3,7 +3,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 +* May 7, 2001 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -169,8 +169,9 @@ * * Apply H(i) to A(i:m,i+1:n) from the left * - CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), - $ A( I, I+1 ), LDA, WORK ) + IF( I.LT.N ) + $ CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), + $ A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN @@ -207,8 +208,9 @@ * * Apply G(i) to A(i+1:m,i:n) from the right * - CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), - $ A( MIN( I+1, M ), I ), LDA, WORK ) + IF( I.LT.M ) + $ CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( MIN( I+1, M ), I ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.M ) THEN diff -uNr LAPACK.orig/SRC/sgees.f LAPACK/SRC/sgees.f --- LAPACK.orig/SRC/sgees.f Thu Nov 4 14:23:33 1999 +++ LAPACK/SRC/sgees.f Fri May 25 15:59:45 2001 @@ -5,6 +5,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVS, SORT @@ -110,10 +111,9 @@ * The dimension of the array WORK. LWORK >= max(1,3*N). * For good performance, LWORK must generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * BWORK (workspace) LOGICAL array, dimension (N) * Not referenced if SORT = 'N'. @@ -138,12 +138,13 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. - LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST, - $ WANTVS + LOGICAL CURSL, LASTSL, LST2SL, SCALEA, WANTST, WANTVS INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, $ IHI, ILO, INXT, IP, ITAU, IWRK, K, MAXB, $ MAXWRK, MINWRK @@ -171,7 +172,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) WANTVS = LSAME( JOBVS, 'V' ) WANTST = LSAME( SORT, 'S' ) IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN @@ -197,7 +197,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 2*N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 ) MINWRK = MAX( 1, 3*N ) IF( .NOT.WANTVS ) THEN @@ -216,19 +216,17 @@ MAXWRK = MAX( MAXWRK, N+HSWORK, 1 ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -13 END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEES ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/sgeesx.f LAPACK/SRC/sgeesx.f --- LAPACK.orig/SRC/sgeesx.f Thu Nov 4 14:23:34 1999 +++ LAPACK/SRC/sgeesx.f Fri May 25 16:00:09 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Do WS calculations if LWORK = -1 (eca) * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT @@ -140,6 +141,10 @@ * N+2*SDIM*(N-SDIM) <= N+N*N/2. * For good performance, LWORK must generally be larger. * +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. +* * IWORK (workspace/output) INTEGER array, dimension (LIWORK) * Not referenced if SENSE = 'N' or 'E'. * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. @@ -171,6 +176,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. @@ -239,7 +246,7 @@ * in the code.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 2*N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 ) MINWRK = MAX( 1, 3*N ) IF( .NOT.WANTVS ) THEN @@ -257,21 +264,24 @@ HSWORK = MAX( K*( K+2 ), 2*N ) MAXWRK = MAX( MAXWRK, N+HSWORK, 1 ) END IF +* +* Estimate the workspace needed by STRSEN. +* + IF( WANTST ) THEN + MAXWRK = MAX( MAXWRK, N+(N*N+1)/2 ) + END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -16 END IF - IF( LWORK.LT.MINWRK ) THEN - INFO = -16 - END IF - IF( LIWORK.LT.1 ) THEN - INFO = -18 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEESX', -INFO ) RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/sgeev.f LAPACK/SRC/sgeev.f --- LAPACK.orig/SRC/sgeev.f Wed Dec 8 16:00:09 1999 +++ LAPACK/SRC/sgeev.f Fri May 25 16:00:38 2001 @@ -4,7 +4,8 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* December 8, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -98,10 +99,9 @@ * if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good * performance, LWORK must generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * INFO (output) INTEGER * = 0: successful exit @@ -114,11 +114,13 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, SCALEA, WANTVL, WANTVR + LOGICAL SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, $ MAXB, MAXWRK, MINWRK, NOUT @@ -149,7 +151,6 @@ * 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 @@ -177,7 +178,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 2*N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = MAX( 1, 3*N ) @@ -198,19 +199,17 @@ MAXWRK = MAX( MAXWRK, 4*N ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -13 END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEEV ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/sgeevx.f LAPACK/SRC/sgeevx.f --- LAPACK.orig/SRC/sgeevx.f Thu Nov 4 14:23:34 1999 +++ LAPACK/SRC/sgeevx.f Fri May 25 16:00:59 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE @@ -179,10 +180,9 @@ * LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). * For good performance, LWORK must generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * IWORK (workspace) INTEGER array, dimension (2*N-2) * If SENSE = 'N' or 'E', not referenced. @@ -198,12 +198,14 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, - $ WNTSNN, WNTSNV + LOGICAL SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, WNTSNN, + $ WNTSNV CHARACTER JOB, SIDE INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXB, $ MAXWRK, MINWRK, NOUT @@ -234,7 +236,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) WANTVL = LSAME( JOBVL, 'V' ) WANTVR = LSAME( JOBVR, 'V' ) WNTSNN = LSAME( SENSE, 'N' ) @@ -273,7 +274,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = MAX( 1, 2*N ) @@ -307,19 +308,17 @@ MAXWRK = MAX( MAXWRK, 3*N, 1 ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -21 END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -21 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGEEVX', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/sgegs.f LAPACK/SRC/sgegs.f --- LAPACK.orig/SRC/sgegs.f Thu Nov 4 14:23:34 1999 +++ LAPACK/SRC/sgegs.f Fri May 25 16:01:48 2001 @@ -5,7 +5,7 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR @@ -22,105 +22,75 @@ * * This routine is deprecated and has been replaced by routine SGGES. * -* SGEGS computes for a pair of N-by-N real nonsymmetric matrices A, B: -* the generalized eigenvalues (alphar +/- alphai*i, beta), the real -* Schur form (A, B), and optionally left and/or right Schur vectors -* (VSL and VSR). -* -* (If only the generalized eigenvalues are needed, use the driver SGEGV -* instead.) -* -* A generalized eigenvalue for a pair of matrices (A,B) is, roughly -* speaking, a scalar w or a ratio alpha/beta = w, such that A - w*B -* is singular. It is usually represented as the pair (alpha,beta), -* as there is a reasonable interpretation for beta=0, and even for -* both being zero. A good beginning reference is the book, "Matrix -* Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press) -* -* The (generalized) Schur form of a pair of matrices is the result of -* multiplying both matrices on the left by one orthogonal matrix and -* both on the right by another orthogonal matrix, these two orthogonal -* matrices being chosen so as to bring the pair of matrices into -* (real) Schur form. -* -* A pair of matrices A, B is in generalized real Schur form if B is -* upper triangular with non-negative diagonal and A is block upper -* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond -* to real generalized eigenvalues, while 2-by-2 blocks of A will be -* "standardized" by making the corresponding elements of B have the -* form: -* [ a 0 ] -* [ 0 b ] -* -* and the pair of corresponding 2-by-2 blocks in A and B will -* have a complex conjugate pair of generalized eigenvalues. -* -* The left and right Schur vectors are the columns of VSL and VSR, -* respectively, where VSL and VSR are the orthogonal matrices -* which reduce A and B to Schur form: -* -* Schur form of (A,B) = ( (VSL)**T A (VSR), (VSL)**T B (VSR) ) +* SGEGS computes the eigenvalues, real Schur form, and, optionally, +* left and or/right Schur vectors of a real matrix pair (A,B). +* Given two square matrices A and B, the generalized real Schur +* factorization has the form +* +* A = Q*S*Z**T, B = Q*T*Z**T +* +* where Q and Z are orthogonal matrices, T is upper triangular, and S +* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal +* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs +* of eigenvalues of (A,B). The columns of Q are the left Schur vectors +* and the columns of Z are the right Schur vectors. +* +* If only the eigenvalues of (A,B) are needed, the driver routine +* SGEGV should be used instead. See SGEGV for a description of the +* eigenvalues of the generalized nonsymmetric eigenvalue problem +* (GNEP). * * Arguments * ========= * * JOBVSL (input) CHARACTER*1 * = 'N': do not compute the left Schur vectors; -* = 'V': compute the left Schur vectors. +* = 'V': compute the left Schur vectors (returned in VSL). * * JOBVSR (input) CHARACTER*1 * = 'N': do not compute the right Schur vectors; -* = 'V': compute the right Schur vectors. +* = 'V': compute the right Schur vectors (returned in VSR). * * N (input) INTEGER * The order of the matrices A, B, VSL, and VSR. N >= 0. * * A (input/output) REAL array, dimension (LDA, N) -* On entry, the first of the pair of matrices whose generalized -* eigenvalues and (optionally) Schur vectors are to be -* computed. -* On exit, the generalized Schur form of A. -* Note: to avoid overflow, the Frobenius norm of the matrix -* A should be less than the overflow threshold. +* On entry, the matrix A. +* On exit, the upper quasi-triangular matrix S from the +* generalized real Schur factorization. * * LDA (input) INTEGER * The leading dimension of A. LDA >= max(1,N). * * B (input/output) REAL array, dimension (LDB, N) -* On entry, the second of the pair of matrices whose -* generalized eigenvalues and (optionally) Schur vectors are -* to be computed. -* On exit, the generalized Schur form of B. -* Note: to avoid overflow, the Frobenius norm of the matrix -* B should be less than the overflow threshold. +* On entry, the matrix B. +* On exit, the upper triangular matrix T from the generalized +* real Schur factorization. * * LDB (input) INTEGER * The leading dimension of B. LDB >= max(1,N). * * ALPHAR (output) REAL array, dimension (N) +* The real parts of each scalar alpha defining an eigenvalue +* of GNEP. +* * ALPHAI (output) REAL array, dimension (N) -* BETA (output) REAL array, dimension (N) -* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will -* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, -* j=1,...,N and BETA(j),j=1,...,N are the diagonals of the -* complex Schur form (A,B) that would result if the 2-by-2 -* diagonal blocks of the real Schur form of (A,B) were further -* reduced to triangular form using 2-by-2 complex unitary -* transformations. If ALPHAI(j) is zero, then the j-th +* The imaginary parts of each scalar alpha defining an +* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th * eigenvalue is real; if positive, then the j-th and (j+1)-st -* eigenvalues are a complex conjugate pair, with ALPHAI(j+1) -* negative. +* eigenvalues are a complex conjugate pair, with +* ALPHAI(j+1) = -ALPHAI(j). * -* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) -* may easily over- or underflow, and BETA(j) may even be zero. -* Thus, the user should avoid naively computing the ratio -* alpha/beta. However, ALPHAR and ALPHAI will be always less -* than and usually comparable with norm(A) in magnitude, and -* BETA always less than and usually comparable with norm(B). +* BETA (output) REAL array, dimension (N) +* The scalars beta that define the eigenvalues of GNEP. +* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and +* beta = BETA(j) represent the j-th eigenvalue of the matrix +* pair (A,B), in one of the forms lambda = alpha/beta or +* mu = beta/alpha. Since either lambda or mu may overflow, +* they should not, in general, be computed. * * VSL (output) REAL array, dimension (LDVSL,N) -* If JOBVSL = 'V', VSL will contain the left Schur vectors. -* (See "Purpose", above.) +* If JOBVSL = 'V', the matrix of left Schur vectors Q. * Not referenced if JOBVSL = 'N'. * * LDVSL (input) INTEGER @@ -128,8 +98,7 @@ * if JOBVSL = 'V', LDVSL >= N. * * VSR (output) REAL array, dimension (LDVSR,N) -* If JOBVSR = 'V', VSR will contain the right Schur vectors. -* (See "Purpose", above.) +* If JOBVSR = 'V', the matrix of right Schur vectors Z. * Not referenced if JOBVSR = 'N'. * * LDVSR (input) INTEGER diff -uNr LAPACK.orig/SRC/sgegv.f LAPACK/SRC/sgegv.f --- LAPACK.orig/SRC/sgegv.f Thu Nov 4 14:25:42 1999 +++ LAPACK/SRC/sgegv.f Fri May 25 16:02:12 2001 @@ -4,7 +4,7 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -21,23 +21,32 @@ * * This routine is deprecated and has been replaced by routine SGGEV. * -* SGEGV computes for a pair of n-by-n real nonsymmetric matrices A and -* B, the generalized eigenvalues (alphar +/- alphai*i, beta), and -* optionally, the left and/or right generalized eigenvectors (VL and -* VR). -* -* A generalized eigenvalue for a pair of matrices (A,B) is, roughly -* speaking, a scalar w or a ratio alpha/beta = w, such that A - w*B -* is singular. It is usually represented as the pair (alpha,beta), -* as there is a reasonable interpretation for beta=0, and even for -* both being zero. A good beginning reference is the book, "Matrix -* Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press) -* -* A right generalized eigenvector corresponding to a generalized -* eigenvalue w for a pair of matrices (A,B) is a vector r such -* that (A - w B) r = 0 . A left generalized eigenvector is a vector -* l such that l**H * (A - w B) = 0, where l**H is the -* conjugate-transpose of l. +* SGEGV computes the eigenvalues and, optionally, the left and/or right +* eigenvectors of a real matrix pair (A,B). +* Given two square matrices A and B, +* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the +* eigenvalues lambda and corresponding (non-zero) eigenvectors x such +* that +* +* A*x = lambda*B*x. +* +* An alternate form is to find the eigenvalues mu and corresponding +* eigenvectors y such that +* +* mu*A*y = B*y. +* +* These two forms are equivalent with mu = 1/lambda and x = y if +* neither lambda nor mu is zero. In order to deal with the case that +* lambda or mu is zero or small, two values alpha and beta are returned +* for each eigenvalue, such that lambda = alpha/beta and +* mu = beta/alpha. +* +* The vectors x and y in the above equations are right eigenvectors of +* the matrix pair (A,B). Vectors u and v satisfying +* +* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B +* +* are left eigenvectors of (A,B). * * Note: this routine performs "full balancing" on A and B -- see * "Further Details", below. @@ -47,63 +56,75 @@ * * JOBVL (input) CHARACTER*1 * = 'N': do not compute the left generalized eigenvectors; -* = 'V': compute the left generalized eigenvectors. +* = 'V': compute the left generalized eigenvectors (returned +* in VL). * * JOBVR (input) CHARACTER*1 * = 'N': do not compute the right generalized eigenvectors; -* = 'V': compute the right generalized eigenvectors. +* = 'V': compute the right generalized eigenvectors (returned +* in VR). * * N (input) INTEGER * The order of the matrices A, B, VL, and VR. N >= 0. * * A (input/output) REAL array, dimension (LDA, N) -* On entry, the first of the pair of matrices whose -* generalized eigenvalues and (optionally) generalized -* eigenvectors are to be computed. -* On exit, the contents will have been destroyed. (For a -* description of the contents of A on exit, see "Further -* Details", below.) +* On entry, the matrix A. +* If JOBVL = 'V' or JOBVR = 'V', then on exit A +* contains the real Schur form of A from the generalized Schur +* factorization of the pair (A,B) after balancing. +* If no eigenvectors were computed, then only the diagonal +* blocks from the Schur form will be correct. See SGGHRD and +* SHGEQZ for details. * * LDA (input) INTEGER * The leading dimension of A. LDA >= max(1,N). * * B (input/output) REAL array, dimension (LDB, N) -* On entry, the second of the pair of matrices whose -* generalized eigenvalues and (optionally) generalized -* eigenvectors are to be computed. -* On exit, the contents will have been destroyed. (For a -* description of the contents of B on exit, see "Further -* Details", below.) +* On entry, the matrix B. +* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the +* upper triangular matrix obtained from B in the generalized +* Schur factorization of the pair (A,B) after balancing. +* If no eigenvectors were computed, then only those elements of +* B corresponding to the diagonal blocks from the Schur form of +* A will be correct. See SGGHRD and SHGEQZ for details. * * LDB (input) INTEGER * The leading dimension of B. LDB >= max(1,N). * * ALPHAR (output) REAL array, dimension (N) +* The real parts of each scalar alpha defining an eigenvalue of +* GNEP. +* * ALPHAI (output) REAL array, dimension (N) -* BETA (output) REAL array, dimension (N) -* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will -* be the generalized eigenvalues. If ALPHAI(j) is zero, then -* the j-th eigenvalue is real; if positive, then the j-th and +* The imaginary parts of each scalar alpha defining an +* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th +* eigenvalue is real; if positive, then the j-th and * (j+1)-st eigenvalues are a complex conjugate pair, with -* ALPHAI(j+1) negative. +* ALPHAI(j+1) = -ALPHAI(j). * -* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) -* may easily over- or underflow, and BETA(j) may even be zero. -* Thus, the user should avoid naively computing the ratio -* alpha/beta. However, ALPHAR and ALPHAI will be always less -* than and usually comparable with norm(A) in magnitude, and -* BETA always less than and usually comparable with norm(B). +* BETA (output) REAL array, dimension (N) +* The scalars beta that define the eigenvalues of GNEP. +* +* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and +* beta = BETA(j) represent the j-th eigenvalue of the matrix +* pair (A,B), in one of the forms lambda = alpha/beta or +* mu = beta/alpha. Since either lambda or mu may overflow, +* they should not, in general, be computed. * * VL (output) REAL array, dimension (LDVL,N) -* If JOBVL = 'V', the left generalized eigenvectors. (See -* "Purpose", above.) Real eigenvectors take one column, -* complex take two columns, the first for the real part and -* the second for the imaginary part. Complex eigenvectors -* correspond to an eigenvalue with positive imaginary part. -* Each eigenvector will be scaled so the largest component -* will have abs(real part) + abs(imag. part) = 1, *except* -* that for eigenvalues with alpha=beta=0, a zero vector will -* be returned as the corresponding eigenvector. +* If JOBVL = 'V', the left eigenvectors u(j) are stored +* in the columns of VL, in the same order as their eigenvalues. +* If the j-th eigenvalue is real, then u(j) = VL(:,j). +* If the j-th and (j+1)-st eigenvalues form a complex conjugate +* pair, then +* u(j) = VL(:,j) + i*VL(:,j+1) +* and +* u(j+1) = VL(:,j) - i*VL(:,j+1). +* +* Each eigenvector is scaled so that its largest component has +* abs(real part) + abs(imag. part) = 1, except for eigenvectors +* corresponding to an eigenvalue with alpha = beta = 0, which +* are set to zero. * Not referenced if JOBVL = 'N'. * * LDVL (input) INTEGER @@ -111,15 +132,19 @@ * if JOBVL = 'V', LDVL >= N. * * VR (output) REAL array, dimension (LDVR,N) -* If JOBVR = 'V', the right generalized eigenvectors. (See -* "Purpose", above.) Real eigenvectors take one column, -* complex take two columns, the first for the real part and -* the second for the imaginary part. Complex eigenvectors -* correspond to an eigenvalue with positive imaginary part. -* Each eigenvector will be scaled so the largest component -* will have abs(real part) + abs(imag. part) = 1, *except* -* that for eigenvalues with alpha=beta=0, a zero vector will -* be returned as the corresponding eigenvector. +* If JOBVR = 'V', the right eigenvectors x(j) are stored +* in the columns of VR, in the same order as their eigenvalues. +* If the j-th eigenvalue is real, then x(j) = VR(:,j). +* If the j-th and (j+1)-st eigenvalues form a complex conjugate +* pair, then +* x(j) = VR(:,j) + i*VR(:,j+1) +* and +* x(j+1) = VR(:,j) - i*VR(:,j+1). +* +* Each eigenvector is scaled so that its largest component has +* abs(real part) + abs(imag. part) = 1, except for eigenvalues +* corresponding to an eigenvalue with alpha = beta = 0, which +* are set to zero. * Not referenced if JOBVR = 'N'. * * LDVR (input) INTEGER diff -uNr LAPACK.orig/SRC/sgelsd.f LAPACK/SRC/sgelsd.f --- LAPACK.orig/SRC/sgelsd.f Thu Nov 4 14:26:24 1999 +++ LAPACK/SRC/sgelsd.f Fri May 25 16:03:05 2001 @@ -4,7 +4,8 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -61,9 +62,10 @@ * The number of right hand sides, i.e., the number of columns * of the matrices B and X. NRHS >= 0. * -* A (input) REAL array, dimension (LDA,N) +* A (input/output) REAL array, dimension (LDA,N) * On entry, the M-by-N matrix A. -* On exit, A has been destroyed. +* On exit, the first min(m,n) rows of A are overwritten with +* its right singular vectors, stored rowwise. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). @@ -95,24 +97,20 @@ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER -* The dimension of the array WORK. LWORK must be at least 1. +* The dimension of the array WORK. LWORK >= 1. * The exact minimum amount of workspace needed depends on M, -* N and NRHS. As long as LWORK is at least -* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, -* if M is greater than or equal to N or -* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, -* if M is less than N, the code will execute correctly. +* N and NRHS. +* If M >= N, LWORK >= 11*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS. +* If M < N, LWORK >= 11*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS. * SMLSIZ is returned by ILAENV and is equal to the maximum * size of the subproblems at the bottom of the computation * tree (usually about 25), and -* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) +* NLVL = INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * IWORK (workspace) INTEGER array, dimension (LIWORK) * LIWORK >= 3 * MINMN * NLVL + 11 * MINMN, @@ -136,14 +134,15 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE, TWO PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ, $ LDWORK, MAXMN, MAXWRK, MINMN, MINWRK, MM, - $ MNTHR, NLVL, NWORK, SMLSIZ, WLALSD + $ MNTHR, NLVL, NWORK, SMLSIZ REAL ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM * .. * .. External Subroutines .. @@ -166,7 +165,6 @@ MINMN = MIN( M, N ) MAXMN = MAX( M, N ) MNTHR = ILAENV( 6, 'SGELSD', ' ', M, N, NRHS, -1 ) - LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN @@ -190,8 +188,8 @@ * MINWRK = 1 MINMN = MAX( 1, MINMN ) - NLVL = MAX( INT( LOG( REAL( MINMN ) / REAL( SMLSIZ+1 ) ) / - $ LOG( TWO ) ) + 1, 0 ) + NLVL = INT( LOG( REAL( MINMN ) / REAL( SMLSIZ+1 ) ) / + $ LOG( TWO ) ) + 1 * IF( INFO.EQ.0 ) THEN MAXWRK = 0 @@ -216,12 +214,11 @@ $ ILAENV( 1, 'SORMBR', 'QLT', MM, NRHS, N, -1 ) ) MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* $ ILAENV( 1, 'SORMBR', 'PLN', N, NRHS, N, -1 ) ) - WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2 - MAXWRK = MAX( MAXWRK, 3*N+WLALSD ) - MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD ) + MAXWRK = MAX( MAXWRK, 3*N+8*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS ) + MINWRK = MAX( 3*N+MM, 3*N+NRHS, + $ 3*N+8*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS ) END IF IF( N.GT.M ) THEN - WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2 IF( N.GE.MNTHR ) THEN * * Path 2a - underdetermined, with many more columns @@ -241,7 +238,8 @@ END IF MAXWRK = MAX( MAXWRK, M+NRHS* $ ILAENV( 1, 'SORMLQ', 'LT', N, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD ) + MAXWRK = MAX( MAXWRK, M*M+4*M+8*M+2*M*SMLSIZ+8*M*NLVL+M* + $ NRHS ) ELSE * * Path 2 - remaining underdetermined cases. @@ -252,26 +250,25 @@ $ ILAENV( 1, 'SORMBR', 'QLT', M, NRHS, N, -1 ) ) MAXWRK = MAX( MAXWRK, 3*M+M* $ ILAENV( 1, 'SORMBR', 'PLN', N, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*M+WLALSD ) + MAXWRK = MAX( MAXWRK, 3*M+8*M+2*M*SMLSIZ+8*M*NLVL+M* + $ NRHS ) END IF - MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD ) + MINWRK = MAX( 3*M+NRHS, 3*M+M, + $ 3*M+8*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS ) END IF MINWRK = MIN( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -12 END IF * +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGELSD', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - GO TO 10 END IF -* -* Quick return if possible. -* + IF( LWORK.EQ.LQUERV ) RETURN IF( M.EQ.0 .OR. N.EQ.0 ) THEN RANK = 0 RETURN diff -uNr LAPACK.orig/SRC/sgelss.f LAPACK/SRC/sgelss.f --- LAPACK.orig/SRC/sgelss.f Thu Nov 4 14:23:34 1999 +++ LAPACK/SRC/sgelss.f Fri May 25 16:03:41 2001 @@ -4,7 +4,7 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -86,10 +86,9 @@ * LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * INFO (output) INTEGER * = 0: successful exit @@ -156,7 +155,7 @@ * following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 0 MM = M IF( M.GE.N .AND. M.GE.MNTHR ) THEN @@ -229,20 +228,18 @@ END IF MAXWRK = MAX( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 END IF * - MINWRK = MAX( MINWRK, 1 ) - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGELSS', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF -* -* Quick return if possible -* IF( M.EQ.0 .OR. N.EQ.0 ) THEN RANK = 0 RETURN @@ -491,8 +488,8 @@ DO 40 I = 1, NRHS, CHUNK BL = MIN( NRHS-I+1, CHUNK ) CALL SGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, - $ B( 1, I ), LDB, ZERO, WORK( IWORK ), N ) - CALL SLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ), + $ B( 1, I ), LDB, ZERO, WORK( IWORK ), M ) + CALL SLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), $ LDB ) 40 CONTINUE ELSE diff -uNr LAPACK.orig/SRC/sgesdd.f LAPACK/SRC/sgesdd.f --- LAPACK.orig/SRC/sgesdd.f Thu Nov 11 20:32:10 1999 +++ LAPACK/SRC/sgesdd.f Fri May 25 16:07:52 2001 @@ -1,10 +1,11 @@ - SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, - $ LWORK, IWORK, INFO ) + SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, + $ WORK, LWORK, IWORK, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBZ @@ -116,16 +117,20 @@ * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= 1. * If JOBZ = 'N', -* LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)). +* LWORK >= max(14*min(M,N)+4, 10*min(M,N)+2+ +* SMLSIZ*(SMLSIZ+8)) + max(M,N) +* where SMLSIZ is returned by ILAENV and is equal to the +* maximum size of the subproblems at the bottom of the +* computation tree (usually about 25). * If JOBZ = 'O', -* LWORK >= 3*min(M,N)*min(M,N) + -* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)). +* LWORK >= 5*min(M,N)*min(M,N) + max(M,N) + 9*min(M,N). * If JOBZ = 'S' or 'A' -* LWORK >= 3*min(M,N)*min(M,N) + -* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)). +* LWORK >= 4*min(M,N)*min(M,N) + max(M,N) + 9*min(M,N). * For good performance, LWORK should generally be larger. -* If LWORK < 0 but other input arguments are legal, WORK(1) -* returns the optimal LWORK. +* +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * IWORK (workspace) INTEGER array, dimension (8*min(M,N)) * @@ -144,15 +149,17 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE - PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS - INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IL, + LOGICAL WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS + INTEGER BDSPAC, BDSPAN, BLK, CHUNK, I, IE, IERR, IL, $ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT, $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK, - $ MNTHR, NWORK, WRKBL + $ MNTHR, NWORK, SMLSIZ, WRKBL REAL ANRM, BIGNUM, EPS, SMLNUM * .. * .. Local Arrays .. @@ -168,10 +175,10 @@ LOGICAL LSAME INTEGER ILAENV REAL SLAMCH, SLANGE - EXTERNAL ILAENV, LSAME, SLAMCH, SLANGE + EXTERNAL SLAMCH, SLANGE, ILAENV, LSAME * .. * .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN, REAL, SQRT + INTRINSIC REAL, INT, MAX, MIN, SQRT * .. * .. Executable Statements .. * @@ -179,7 +186,7 @@ * INFO = 0 MINMN = MIN( M, N ) - MNTHR = INT( MINMN*11.0E0 / 6.0E0 ) + MNTHR = INT( MINMN*11.0 / 6.0 ) WNTQA = LSAME( JOBZ, 'A' ) WNTQS = LSAME( JOBZ, 'S' ) WNTQAS = WNTQA .OR. WNTQS @@ -187,7 +194,6 @@ WNTQN = LSAME( JOBZ, 'N' ) MINWRK = 1 MAXWRK = 1 - LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN INFO = -1 @@ -206,6 +212,8 @@ INFO = -10 END IF * + SMLSIZ = ILAENV( 9, 'SGESDD', ' ', 0, 0, 0, 0 ) +* * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, @@ -218,22 +226,19 @@ * * Compute space needed for SBDSDC * - IF( WNTQN ) THEN - BDSPAC = 7*N - ELSE - BDSPAC = 3*N*N + 4*N - END IF + BDSPAC = 3*N*N + 7*N + BDSPAN = MAX( 12*N+4, 8*N+2+SMLSIZ*( SMLSIZ+8 ) ) IF( M.GE.MNTHR ) THEN IF( WNTQN ) THEN * * Path 1 (M much larger than N, JOBZ='N') * - WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, - $ -1 ) - WRKBL = MAX( WRKBL, 3*N+2*N* - $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+N ) - MINWRK = BDSPAC + N + MAXWRK = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, 3*N+2*N* + $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MINWRK = BDSPAC ELSE IF( WNTQO ) THEN * * Path 2 (M much larger than N, JOBZ='O') @@ -247,9 +252,9 @@ $ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) ) WRKBL = MAX( WRKBL, 3*N+N* $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) + WRKBL = MAX( WRKBL, BDSPAC+2*N ) MAXWRK = WRKBL + 2*N*N - MINWRK = BDSPAC + 2*N*N + 3*N + MINWRK = BDSPAC + 2*N*N + 2*N ELSE IF( WNTQS ) THEN * * Path 3 (M much larger than N, JOBZ='S') @@ -263,9 +268,9 @@ $ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) ) WRKBL = MAX( WRKBL, 3*N+N* $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) + WRKBL = MAX( WRKBL, BDSPAC+2*N ) MAXWRK = WRKBL + N*N - MINWRK = BDSPAC + N*N + 3*N + MINWRK = BDSPAC + N*N + 2*N ELSE IF( WNTQA ) THEN * * Path 4 (M much larger than N, JOBZ='A') @@ -279,9 +284,9 @@ $ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) ) WRKBL = MAX( WRKBL, 3*N+N* $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) - MAXWRK = WRKBL + N*N - MINWRK = BDSPAC + N*N + 3*N + WRKBL = MAX( WRKBL, BDSPAC+2*N ) + MAXWRK = N*N + WRKBL + MINWRK = BDSPAC + N*N + M + N END IF ELSE * @@ -289,53 +294,47 @@ * WRKBL = 3*N + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N, -1, $ -1 ) - IF( WNTQN ) THEN - MAXWRK = MAX( WRKBL, BDSPAC+3*N ) - MINWRK = 3*N + MAX( M, BDSPAC ) - ELSE IF( WNTQO ) THEN + IF( WNTQO ) THEN WRKBL = MAX( WRKBL, 3*N+N* $ ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) ) WRKBL = MAX( WRKBL, 3*N+N* $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*N ) + WRKBL = MAX( WRKBL, BDSPAC+2*N+M ) MAXWRK = WRKBL + M*N - MINWRK = 3*N + MAX( M, N*N+BDSPAC ) + MINWRK = BDSPAC + N*N + 2*N + M ELSE IF( WNTQS ) THEN - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+3*N ) - MINWRK = 3*N + MAX( M, BDSPAC ) + MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC+2*N+M ) + MINWRK = BDSPAC + 2*N + M ELSE IF( WNTQA ) THEN - WRKBL = MAX( WRKBL, 3*N+M* - $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*N+N* - $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC+3*N ) - MINWRK = 3*N + MAX( M, BDSPAC ) + MAXWRK = MAX( MAXWRK, 3*N+M* + $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC+2*N+M ) + MINWRK = BDSPAC + 2*N + M END IF END IF ELSE * * Compute space needed for SBDSDC * - IF( WNTQN ) THEN - BDSPAC = 7*M - ELSE - BDSPAC = 3*M*M + 4*M - END IF + BDSPAC = 3*M*M + 7*M + BDSPAN = MAX( 12*M+4, 8*M+2+SMLSIZ*( SMLSIZ+8 ) ) IF( N.GE.MNTHR ) THEN IF( WNTQN ) THEN * * Path 1t (N much larger than M, JOBZ='N') * - WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, - $ -1 ) - WRKBL = MAX( WRKBL, 3*M+2*M* - $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+M ) - MINWRK = BDSPAC + M + MAXWRK = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, 3*M+2*M* + $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC ) + MINWRK = BDSPAC ELSE IF( WNTQO ) THEN * * Path 2t (N much larger than M, JOBZ='O') @@ -349,9 +348,9 @@ $ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) ) WRKBL = MAX( WRKBL, 3*M+M* $ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) + WRKBL = MAX( WRKBL, BDSPAC+2*M ) MAXWRK = WRKBL + 2*M*M - MINWRK = BDSPAC + 2*M*M + 3*M + MINWRK = BDSPAC + 2*M*M + 2*M ELSE IF( WNTQS ) THEN * * Path 3t (N much larger than M, JOBZ='S') @@ -365,9 +364,9 @@ $ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) ) WRKBL = MAX( WRKBL, 3*M+M* $ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) + WRKBL = MAX( WRKBL, BDSPAC+2*M ) MAXWRK = WRKBL + M*M - MINWRK = BDSPAC + M*M + 3*M + MINWRK = BDSPAC + M*M + 2*M ELSE IF( WNTQA ) THEN * * Path 4t (N much larger than M, JOBZ='A') @@ -381,9 +380,9 @@ $ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) ) WRKBL = MAX( WRKBL, 3*M+M* $ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) + WRKBL = MAX( WRKBL, BDSPAC+2*M ) MAXWRK = WRKBL + M*M - MINWRK = BDSPAC + M*M + 3*M + MINWRK = BDSPAC + M*M + M + N END IF ELSE * @@ -391,52 +390,46 @@ * WRKBL = 3*M + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N, -1, $ -1 ) - IF( WNTQN ) THEN - MAXWRK = MAX( WRKBL, BDSPAC+3*M ) - MINWRK = 3*M + MAX( N, BDSPAC ) - ELSE IF( WNTQO ) THEN + IF( WNTQO ) THEN WRKBL = MAX( WRKBL, 3*M+M* $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) ) WRKBL = MAX( WRKBL, 3*M+M* $ ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) ) - WRKBL = MAX( WRKBL, BDSPAC+3*M ) + WRKBL = MAX( WRKBL, BDSPAC+2*M ) MAXWRK = WRKBL + M*N - MINWRK = 3*M + MAX( N, M*M+BDSPAC ) + MINWRK = BDSPAC + M*M + 2*M + N ELSE IF( WNTQS ) THEN - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+3*M ) - MINWRK = 3*M + MAX( N, BDSPAC ) + MAXWRK = MAX( MAXWRK, 3*M+M* + $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M+M* + $ ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC+2*M ) + MINWRK = BDSPAC + 2*M + N ELSE IF( WNTQA ) THEN - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) ) - WRKBL = MAX( WRKBL, 3*M+M* - $ ILAENV( 1, 'SORMBR', 'PRT', N, N, M, -1 ) ) - MAXWRK = MAX( WRKBL, BDSPAC+3*M ) - MINWRK = 3*M + MAX( N, BDSPAC ) + MAXWRK = MAX( MAXWRK, 3*M+M* + $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M+N* + $ ILAENV( 1, 'SORMBR', 'PRT', N, N, M, -1 ) ) + MAXWRK = MAX( MAXWRK, BDSPAC+2*M ) + MINWRK = BDSPAC + 2*M + N END IF END IF END IF + END IF + IF( INFO.EQ.0 ) THEN WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -12 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGESDD', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE RETURN END IF * @@ -497,7 +490,7 @@ NWORK = IE + N * * Perform bidiagonal SVD, computing singular values only -* (Workspace: need N+BDSPAC) +* (Workspace: need BDSPAN) * CALL SBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) @@ -512,10 +505,10 @@ * * WORK(IR) is LDWRKR by N * - IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN + IF( LWORK.GE.LDA*N+4*N*N+9*N ) THEN LDWRKR = LDA ELSE - LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N + LDWRKR = ( LWORK-4*N*N-9*N ) / N END IF ITAU = IR + LDWRKR*N NWORK = ITAU + N @@ -557,7 +550,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT -* (Workspace: need N+N*N+BDSPAC) +* (Workspace: need 2*N*N+BDSPAC) * CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -633,7 +626,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagoal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need N+BDSPAC) +* (Workspace: need N*N+BDSPAC) * CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -681,7 +674,7 @@ CALL SLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U -* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) +* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) * @@ -703,7 +696,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT -* (Workspace: need N+N*N+BDSPAC) +* (Workspace: need N*N+BDSPAC) * CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -754,13 +747,13 @@ IF( WNTQN ) THEN * * Perform bidiagonal SVD, only computing singular values -* (Workspace: need N+BDSPAC) +* (Workspace: need BDSPAN) * CALL SBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN IU = NWORK - IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN + IF( LWORK.GE.M*N+3*N*N+9*N ) THEN * * WORK( IU ) is M by N * @@ -785,7 +778,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT -* (Workspace: need N+N*N+BDSPAC) +* (Workspace: need N*N+BDSPAC) * CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), $ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ), @@ -798,7 +791,7 @@ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK-NWORK+1, IERR ) * - IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN + IF( LWORK.GE.M*N+3*N*N+9*N ) THEN * * Overwrite WORK(IU) by left singular vectors of A * (Workspace: need N*N+2*N, prefer N*N+N+N*NB) @@ -838,7 +831,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need N+BDSPAC) +* (Workspace: need BDSPAC) * CALL SLASET( 'F', M, N, ZERO, ZERO, U, LDU ) CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, @@ -855,12 +848,12 @@ CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK-NWORK+1, IERR ) - ELSE IF( WNTQA ) THEN + ELSE * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need N+BDSPAC) +* (Workspace: need BDSPAC) * CALL SLASET( 'F', M, M, ZERO, ZERO, U, LDU ) CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, @@ -925,7 +918,7 @@ NWORK = IE + M * * Perform bidiagonal SVD, computing singular values only -* (Workspace: need M+BDSPAC) +* (Workspace: need BDSPAN) * CALL SBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) @@ -941,7 +934,7 @@ * IVT is M by M * IL = IVT + M*M - IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN + IF( LWORK.GE.M*N+4*M*M+9*M ) THEN * * WORK(IL) is M by N * @@ -986,7 +979,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U, and computing right singular * vectors of bidiagonal matrix in WORK(IVT) -* (Workspace: need M+M*M+BDSPAC) +* (Workspace: need 2*M*M+BDSPAC) * CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ), @@ -1061,7 +1054,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need M+BDSPAC) +* (Workspace: need M*M+BDSPAC) * CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, @@ -1108,7 +1101,7 @@ CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT -* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) +* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) * CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( NWORK ), LWORK-NWORK+1, IERR ) @@ -1131,7 +1124,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in WORK(IVT) -* (Workspace: need M+M*M+BDSPAC) +* (Workspace: need M*M+BDSPAC) * CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), LDWKVT, DUM, IDUM, @@ -1182,14 +1175,14 @@ IF( WNTQN ) THEN * * Perform bidiagonal SVD, only computing singular values -* (Workspace: need M+BDSPAC) +* (Workspace: need BDSPAN) * CALL SBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN LDWKVT = M IVT = NWORK - IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN + IF( LWORK.GE.M*N+3*M*M+9*M ) THEN * * WORK( IVT ) is M by N * @@ -1224,7 +1217,7 @@ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK-NWORK+1, IERR ) * - IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN + IF( LWORK.GE.M*N+3*M*M+9*M ) THEN * * Overwrite WORK(IVT) by left singular vectors of A * (Workspace: need M*M+2*M, prefer M*M+M+M*NB) @@ -1263,7 +1256,7 @@ * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need M+BDSPAC) +* (Workspace: need BDSPAC) * CALL SLASET( 'F', M, N, ZERO, ZERO, VT, LDVT ) CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, @@ -1280,12 +1273,12 @@ CALL SORMBR( 'P', 'R', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK-NWORK+1, IERR ) - ELSE IF( WNTQA ) THEN + ELSE * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT -* (Workspace: need M+BDSPAC) +* (Workspace: need BDSPAC) * CALL SLASET( 'F', N, N, ZERO, ZERO, VT, LDVT ) CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, @@ -1319,9 +1312,15 @@ IF( ANRM.GT.BIGNUM ) $ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) + IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) + $ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ), + $ MINMN, IERR ) IF( ANRM.LT.SMLNUM ) $ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) + IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) + $ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ), + $ MINMN, IERR ) END IF * * Return optimal workspace in WORK(1) diff -uNr LAPACK.orig/SRC/sgesvd.f LAPACK/SRC/sgesvd.f --- LAPACK.orig/SRC/sgesvd.f Thu Nov 4 14:23:35 1999 +++ LAPACK/SRC/sgesvd.f Fri May 25 16:08:20 2001 @@ -4,7 +4,8 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT @@ -118,10 +119,9 @@ * LWORK >= MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * INFO (output) INTEGER * = 0: successful exit. @@ -134,12 +134,14 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, - $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS + LOGICAL WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, WNTVA, + $ WNTVAS, WNTVN, WNTVO, WNTVS INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL, $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, @@ -181,7 +183,7 @@ WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) MINWRK = 1 - LQUERY = ( LWORK.EQ.-1 ) + MAXWRK = 1 * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN INFO = -1 @@ -208,8 +210,7 @@ * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. - $ N.GT.0 ) THEN + IF( INFO.EQ.0 .AND. M.GT.0 .AND. N.GT.0 ) THEN IF( M.GE.N ) THEN * * Compute space needed for SBDSQR @@ -557,24 +558,21 @@ MAXWRK = MAX( MAXWRK, MINWRK ) END IF END IF + END IF + IF( INFO.EQ.0 ) THEN WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -13 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGESVD', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE RETURN END IF * diff -uNr LAPACK.orig/SRC/sggbak.f LAPACK/SRC/sggbak.f --- LAPACK.orig/SRC/sggbak.f Thu Nov 4 14:23:36 1999 +++ LAPACK/SRC/sggbak.f Fri May 25 16:08:51 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* February 1, 2001 * * .. Scalar Arguments .. CHARACTER JOB, SIDE @@ -108,10 +108,15 @@ INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 - ELSE IF( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) THEN + ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN + INFO = -4 + ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) + $ THEN + INFO = -5 + ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN - INFO = -6 + INFO = -8 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF diff -uNr LAPACK.orig/SRC/sggbal.f LAPACK/SRC/sggbal.f --- LAPACK.orig/SRC/sggbal.f Thu Nov 4 14:25:42 1999 +++ LAPACK/SRC/sggbal.f Fri May 25 16:09:11 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* April 12, 2001 * * .. Scalar Arguments .. CHARACTER JOB @@ -141,7 +141,7 @@ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -5 + INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGGBAL', -INFO ) @@ -188,8 +188,8 @@ IF( L.NE.1 ) $ GO TO 30 * - RSCALE( 1 ) = 1 - LSCALE( 1 ) = 1 + RSCALE( 1 ) = ONE + LSCALE( 1 ) = ONE GO TO 190 * 30 CONTINUE @@ -247,7 +247,7 @@ * Permute rows M and I * 160 CONTINUE - LSCALE( M ) = I + LSCALE( M ) = REAL( I ) IF( I.EQ.M ) $ GO TO 170 CALL SSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) @@ -256,7 +256,7 @@ * Permute columns M and J * 170 CONTINUE - RSCALE( M ) = J + RSCALE( M ) = REAL( J ) IF( J.EQ.M ) $ GO TO 180 CALL SSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) @@ -424,7 +424,7 @@ DO 360 I = ILO, IHI IRAB = ISAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) - IRAB = ISAMAX( N-ILO+1, B( I, ILO ), LDA ) + IRAB = ISAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) diff -uNr LAPACK.orig/SRC/sgges.f LAPACK/SRC/sgges.f --- LAPACK.orig/SRC/sgges.f Thu Nov 4 14:26:20 1999 +++ LAPACK/SRC/sgges.f Fri May 25 16:09:33 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SORT @@ -158,10 +159,9 @@ * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= 8*N+16. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * BWORK (workspace) LOGICAL array, dimension (N) * Not referenced if SORT = 'N'. @@ -184,12 +184,14 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, - $ LQUERY, LST2SL, WANTST + $ LST2SL, WANTST INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, $ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, MAXWRK, $ MINWRK @@ -245,7 +247,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN @@ -272,7 +273,7 @@ * following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MINWRK = 7*( N+1 ) + 16 MAXWRK = 7*( N+1 ) + N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 ) + $ 16 @@ -281,19 +282,17 @@ $ ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 ) ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -19 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -19 +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGGES ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/sggesx.f LAPACK/SRC/sggesx.f --- LAPACK.orig/SRC/sggesx.f Thu Nov 4 14:26:20 1999 +++ LAPACK/SRC/sggesx.f Fri May 25 16:09:52 2001 @@ -7,6 +7,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Do WS calculations if LWORK = -1 (eca) * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SENSE, SORT @@ -185,6 +186,10 @@ * If SENSE = 'E', 'V', or 'B', * LWORK >= MAX( 8*(N+1)+16, 2*SDIM*(N-SDIM) ). * +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. +* * IWORK (workspace) INTEGER array, dimension (LIWORK) * Not referenced if SENSE = 'N'. * @@ -227,6 +232,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. @@ -330,7 +337,7 @@ * following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + IF( INFO.EQ.0 ) THEN MINWRK = 8*( N+1 ) + 16 MAXWRK = 7*( N+1 ) + N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 ) + $ 16 @@ -338,7 +345,15 @@ MAXWRK = MAX( MAXWRK, 8*( N+1 )+N* $ ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 )+16 ) END IF +* +* Estimate the workspace needed by STGSEN. +* + IF( WANTST ) THEN + MAXWRK = MAX( MAXWRK, 2*N+(N*N+1)/2 ) + END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -22 END IF IF( .NOT.WANTSN ) THEN LIWMIN = 1 @@ -346,21 +361,18 @@ LIWMIN = N + 6 END IF IWORK( 1 ) = LIWMIN -* - IF( INFO.EQ.0 .AND. LWORK.LT.MINWRK ) THEN - INFO = -22 - ELSE IF( INFO.EQ.0 .AND. IJOB.GE.1 ) THEN + IF( INFO.EQ.0 .AND. IJOB.GE.1 ) THEN IF( LIWORK.LT.LIWMIN ) $ INFO = -24 END IF * +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGGESX', -INFO ) RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/sggev.f LAPACK/SRC/sggev.f --- LAPACK.orig/SRC/sggev.f Thu Nov 4 14:26:20 1999 +++ LAPACK/SRC/sggev.f Fri May 25 16:10:10 2001 @@ -5,6 +5,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -123,10 +124,9 @@ * The dimension of the array WORK. LWORK >= max(1,8*N). * For good performance, LWORK must generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * INFO (output) INTEGER * = 0: successful exit @@ -141,11 +141,13 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. - LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR CHARACTER CHTEMP INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, $ IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, MAXWRK, @@ -200,7 +202,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN @@ -226,24 +227,21 @@ * computed assuming ILO = 1 and IHI = N, the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 7*N + N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 ) MINWRK = MAX( 1, 8*N ) WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -16 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -16 +* Quick returns * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGGEV ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/sggevx.f LAPACK/SRC/sggevx.f --- LAPACK.orig/SRC/sggevx.f Thu Nov 4 14:26:20 1999 +++ LAPACK/SRC/sggevx.f Fri May 25 16:11:25 2001 @@ -7,6 +7,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE @@ -212,10 +213,9 @@ * If SENSE = 'E', LWORK >= 12*N. * If SENSE = 'V' or 'B', LWORK >= 2*N*N+12*N+16. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * IWORK (workspace) INTEGER array, dimension (N+6) * If SENSE = 'E', IWORK is not referenced. @@ -262,12 +262,14 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. - LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, PAIR, - $ WANTSB, WANTSE, WANTSN, WANTSV + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, PAIR, WANTSB, + $ WANTSE, WANTSN, WANTSV CHARACTER CHTEMP INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS, $ ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK, @@ -327,7 +329,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, $ 'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) $ THEN @@ -360,7 +361,7 @@ * computed assuming ILO = 1 and IHI = N, the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 5*N + N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 ) MINWRK = MAX( 1, 6*N ) IF( WANTSE ) THEN @@ -370,24 +371,19 @@ MAXWRK = MAX( MAXWRK, 2*N*N+12*N+16 ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -26 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -26 - END IF +* Quick returns * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGGEVX', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) RETURN IF( N.EQ.0 ) $ RETURN -* * * Get machine constants * diff -uNr LAPACK.orig/SRC/sgghrd.f LAPACK/SRC/sgghrd.f --- LAPACK.orig/SRC/sgghrd.f Thu Nov 4 14:25:44 1999 +++ LAPACK/SRC/sgghrd.f Fri May 25 16:11:45 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ @@ -20,16 +20,32 @@ * * SGGHRD reduces a pair of real matrices (A,B) to generalized upper * Hessenberg form using orthogonal transformations, where A is a -* general matrix and B is upper triangular: Q' * A * Z = H and -* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, -* and Q and Z are orthogonal, and ' means transpose. +* general matrix and B is upper triangular. The form of the +* generalized eigenvalue problem is +* A*x = lambda*B*x, +* and B is typically made upper triangular by computing its QR +* factorization and moving the orthogonal matrix Q to the left side +* of the equation. +* +* This subroutine simultaneously reduces A to a Hessenberg matrix H: +* Q**T*A*Z = H +* and transforms B to another upper triangular matrix T: +* Q**T*B*Z = T +* in order to reduce the problem to its standard form +* H*y = lambda*T*y +* where y = Z**T*x. * * The orthogonal matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be -* postmultiplied into input matrices Q1 and Z1, so that +* postmultiplied into input matrices Q1 and Z1, so that * -* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' -* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' +* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T +* +* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T +* +* If Q1 is the orthogonal matrix from the QR factorization of B in the +* original equation A*x = lambda*B*x, then SGGHRD reduces the original +* problem to generalized Hessenberg form. * * Arguments * ========= @@ -53,10 +69,11 @@ * * 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 SGGBAL; otherwise they should be set -* to 1 and N respectively. +* ILO and IHI mark the rows and columns of A which are to be +* reduced. 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 SGGBAL; otherwise they +* should be set to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) REAL array, dimension (LDA, N) @@ -70,33 +87,28 @@ * * B (input/output) REAL array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. -* On exit, the upper triangular matrix T = Q' B Z. The +* On exit, the upper triangular matrix T = Q**T B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) REAL array, dimension (LDQ, N) -* If COMPQ='N': Q is not referenced. -* If COMPQ='I': on entry, Q need not be set, and on exit it -* contains the orthogonal matrix Q, where Q' -* is the product of the Givens transformations -* which are applied to A and B on the left. -* If COMPQ='V': on entry, Q must contain an orthogonal matrix -* Q1, and on exit this is overwritten by Q1*Q. +* On entry, if COMPQ = 'V', the orthogonal matrix Q1, +* typically from the QR factorization of B. +* On exit, if COMPQ='I', the orthogonal matrix Q, and if +* COMPQ = 'V', the product Q1*Q. +* Not referenced if COMPQ='N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * Z (input/output) REAL array, dimension (LDZ, N) -* If COMPZ='N': Z is not referenced. -* If COMPZ='I': on entry, Z need not be set, and on exit it -* contains the orthogonal matrix Z, which is -* the product of the Givens transformations -* which are applied to A and B on the right. -* If COMPZ='V': on entry, Z must contain an orthogonal matrix -* Z1, and on exit this is overwritten by Z1*Z. +* On entry, if COMPZ = 'V', the orthogonal matrix Z1. +* On exit, if COMPZ='I', the orthogonal matrix Z, and if +* COMPZ = 'V', the product Z1*Z. +* Not referenced if COMPZ='N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. diff -uNr LAPACK.orig/SRC/shgeqz.f LAPACK/SRC/shgeqz.f --- LAPACK.orig/SRC/shgeqz.f Thu Nov 4 14:23:36 1999 +++ LAPACK/SRC/shgeqz.f Fri May 25 16:12:05 2001 @@ -1,56 +1,75 @@ - SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, + SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 3, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. - REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), - $ B( LDB, * ), BETA( * ), Q( LDQ, * ), WORK( * ), - $ Z( LDZ, * ) + REAL ALPHAI( * ), ALPHAR( * ), BETA( * ), + $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), + $ WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * -* SHGEQZ implements a single-/double-shift version of the QZ method for -* finding the generalized eigenvalues -* -* w(j)=(ALPHAR(j) + i*ALPHAI(j))/BETAR(j) of the equation -* -* det( A - w(i) B ) = 0 -* -* In addition, the pair A,B may be reduced to generalized Schur form: -* B is upper triangular, and A is block upper triangular, where the -* diagonal blocks are either 1-by-1 or 2-by-2, the 2-by-2 blocks having -* complex generalized eigenvalues (see the description of the argument -* JOB.) -* -* If JOB='S', then the pair (A,B) is simultaneously reduced to Schur -* form by applying one orthogonal tranformation (usually called Q) on -* the left and another (usually called Z) on the right. The 2-by-2 -* upper-triangular diagonal blocks of B corresponding to 2-by-2 blocks -* of A will be reduced to positive diagonal matrices. (I.e., -* if A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) and -* B(j+1,j+1) will be positive.) -* -* If JOB='E', then at each iteration, the same transformations -* are computed, but they are only applied to those parts of A and B -* which are needed to compute ALPHAR, ALPHAI, and BETAR. -* -* If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the orthogonal -* transformations used to reduce (A,B) are accumulated into the arrays -* Q and Z s.t.: -* -* Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* -* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* +* SHGEQZ computes the eigenvalues of a real matrix pair (H,T), +* where H is an upper Hessenberg matrix and T is upper triangular, +* using the double-shift QZ method. +* Matrix pairs of this type are produced by the reduction to +* generalized upper Hessenberg form of a real matrix pair (A,B): +* +* A = Q1*H*Z1**T, B = Q1*T*Z1**T, +* +* as computed by SGGHRD. +* +* If JOB='S', then the Hessenberg-triangular pair (H,T) is +* also reduced to generalized Schur form, +* +* H = Q*S*Z**T, T = Q*P*Z**T, +* +* where Q and Z are orthogonal matrices, P is an upper triangular +* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 +* diagonal blocks. +* +* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair +* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of +* eigenvalues. +* +* Additionally, the 2-by-2 upper triangular diagonal blocks of P +* corresponding to 2-by-2 blocks of S are reduced to positive diagonal +* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, +* P(j,j) > 0, and P(j+1,j+1) > 0. +* +* Optionally, the orthogonal matrix Q from the generalized Schur +* factorization may be postmultiplied into an input matrix Q1, and the +* orthogonal matrix Z may be postmultiplied into an input matrix Z1. +* If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced +* the matrix pair (A,B) to generalized upper Hessenberg form, then the +* output matrices Q1*Q and Z1*Z are the orthogonal factors from the +* generalized Schur factorization of (A,B): +* +* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. +* +* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, +* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is +* complex and beta real. +* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the +* generalized nonsymmetric eigenvalue problem (GNEP) +* A*x = lambda*B*x +* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the +* alternate form of the GNEP +* mu*A*y = B*y. +* Real eigenvalues can be read directly from the generalized Schur +* form: +* alpha = S(i,i), beta = P(i,i). * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), @@ -60,114 +79,98 @@ * ========= * * JOB (input) CHARACTER*1 -* = 'E': compute only ALPHAR, ALPHAI, and BETA. A and B will -* not necessarily be put into generalized Schur form. -* = 'S': put A and B into generalized Schur form, as well -* as computing ALPHAR, ALPHAI, and BETA. +* = 'E': Compute eigenvalues only; +* = 'S': Compute eigenvalues and the Schur form. * * COMPQ (input) CHARACTER*1 -* = 'N': do not modify Q. -* = 'V': multiply the array Q on the right by the transpose of -* the orthogonal tranformation that is applied to the -* left side of A and B to reduce them to Schur form. -* = 'I': like COMPQ='V', except that Q will be initialized to -* the identity first. +* = 'N': Left Schur vectors (Q) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Q +* of left Schur vectors of (H,T) is returned; +* = 'V': Q must contain an orthogonal matrix Q1 on entry and +* the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 -* = 'N': do not modify Z. -* = 'V': multiply the array Z on the right by the orthogonal -* tranformation that is applied to the right side of -* A and B to reduce them to Schur form. -* = 'I': like COMPZ='V', except that Z will be initialized to -* the identity first. +* = 'N': Right Schur vectors (Z) are not computed; +* = 'I': Z is initialized to the unit matrix and the matrix Z +* of right Schur vectors of (H,T) is returned; +* = 'V': Z must contain an orthogonal matrix Z1 on entry and +* the product Z1*Z is returned. * * N (input) INTEGER -* The order of the matrices A, B, Q, and Z. N >= 0. +* The order of the matrices H, T, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* A (input/output) REAL array, dimension (LDA, N) -* On entry, the N-by-N upper Hessenberg matrix A. Elements -* below the subdiagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to generalized Schur form. -* If JOB='E', then on exit A will have been destroyed. -* The diagonal blocks will be correct, but the off-diagonal -* portion will be meaningless. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max( 1, N ). -* -* B (input/output) REAL array, dimension (LDB, N) -* On entry, the N-by-N upper triangular matrix B. Elements -* below the diagonal must be zero. 2-by-2 blocks in B -* corresponding to 2-by-2 blocks in A will be reduced to -* positive diagonal form. (I.e., if A(j+1,j) is non-zero, -* then B(j+1,j)=B(j,j+1)=0 and B(j,j) and B(j+1,j+1) will be -* positive.) -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to Schur form. -* If JOB='E', then on exit B will have been destroyed. -* Elements corresponding to diagonal blocks of A will be -* correct, but the off-diagonal portion will be meaningless. +* ILO and IHI mark the rows and columns of H which are in +* Hessenberg form. It is assumed that A is already upper +* triangular in rows and columns 1:ILO-1 and IHI+1:N. +* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. +* +* H (input/output) REAL array, dimension (LDH, N) +* On entry, the N-by-N upper Hessenberg matrix H. +* On exit, if JOB = 'S', H contains the upper quasi-triangular +* matrix S from the generalized Schur factorization; +* 2-by-2 diagonal blocks (corresponding to complex conjugate +* pairs of eigenvalues) are returned in standard form, with +* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. +* If JOB = 'E', the diagonal blocks of H match those of S, but +* the rest of H is unspecified. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH >= max( 1, N ). +* +* T (input/output) REAL array, dimension (LDT, N) +* On entry, the N-by-N upper triangular matrix T. +* On exit, if JOB = 'S', T contains the upper triangular +* matrix P from the generalized Schur factorization; +* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S +* are reduced to positive diagonal form, i.e., if H(j+1,j) is +* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and +* T(j+1,j+1) > 0. +* If JOB = 'E', the diagonal blocks of T match those of P, but +* the rest of T is unspecified. * -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max( 1, N ). +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max( 1, N ). * * ALPHAR (output) REAL array, dimension (N) -* ALPHAR(1:N) will be set to real parts of the diagonal -* elements of A that would result from reducing A and B to -* Schur form and then further reducing them both to triangular -* form using unitary transformations s.t. the diagonal of B -* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=A(j,j). -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. +* The real parts of each scalar alpha defining an eigenvalue +* of GNEP. * * ALPHAI (output) REAL array, dimension (N) -* ALPHAI(1:N) will be set to imaginary parts of the diagonal -* elements of A that would result from reducing A and B to -* Schur form and then further reducing them both to triangular -* form using unitary transformations s.t. the diagonal of B -* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=0. -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. +* The imaginary parts of each scalar alpha defining an +* eigenvalue of GNEP. +* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if +* positive, then the j-th and (j+1)-st eigenvalues are a +* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). * * BETA (output) REAL array, dimension (N) -* BETA(1:N) will be set to the (real) diagonal elements of B -* that would result from reducing A and B to Schur form and -* then further reducing them both to triangular form using -* unitary transformations s.t. the diagonal of B was -* non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then BETA(j)=B(j,j). -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. -* (Note that BETA(1:N) will always be non-negative, and no -* BETAI is necessary.) +* The scalars beta that define the eigenvalues of GNEP. +* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and +* beta = BETA(j) represent the j-th eigenvalue of the matrix +* pair (A,B), in one of the forms lambda = alpha/beta or +* mu = beta/alpha. Since either lambda or mu may overflow, +* they should not, in general, be computed. * * Q (input/output) REAL array, dimension (LDQ, N) -* If COMPQ='N', then Q will not be referenced. -* If COMPQ='V' or 'I', then the transpose of the orthogonal -* transformations which are applied to A and B on the left -* will be applied to the array Q on the right. +* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur +* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix +* of left Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) REAL array, dimension (LDZ, N) -* If COMPZ='N', then Z will not be referenced. -* If COMPZ='V' or 'I', then the orthogonal transformations -* which are applied to A and B on the right will be applied -* to the array Z on the right. +* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of +* right Schur vectors of (H,T), and if COMPZ = 'V', the +* orthogonal matrix of right Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. @@ -187,13 +190,12 @@ * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value -* = 1,...,N: the QZ iteration did not converge. (A,B) is not +* = 1,...,N: the QZ iteration did not converge. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO+1,...,N should be correct. -* = N+1,...,2*N: the shift calculation failed. (A,B) is not +* = N+1,...,2*N: the shift calculation failed. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO-N+1,...,N should be correct. -* > 2*N: various "impossible" errors. * * Further Details * =============== @@ -225,7 +227,7 @@ $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, - $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T, + $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, $ WR2 @@ -302,9 +304,9 @@ INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 - ELSE IF( LDA.LT.N ) THEN + ELSE IF( LDH.LT.N ) THEN INFO = -8 - ELSE IF( LDB.LT.N ) THEN + ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -15 @@ -340,8 +342,8 @@ SAFMIN = SLAMCH( 'S' ) SAFMAX = ONE / SAFMIN ULP = SLAMCH( 'E' )*SLAMCH( 'B' ) - ANORM = SLANHS( 'F', IN, A( ILO, ILO ), LDA, WORK ) - BNORM = SLANHS( 'F', IN, B( ILO, ILO ), LDB, WORK ) + ANORM = SLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) + BNORM = SLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) @@ -350,15 +352,15 @@ * Set Eigenvalues IHI+1:N * DO 30 J = IHI + 1, N - IF( B( J, J ).LT.ZERO ) THEN + IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 10 JR = 1, J - A( JR, J ) = -A( JR, J ) - B( JR, J ) = -B( JR, J ) + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) 10 CONTINUE ELSE - A( J, J ) = -A( J, J ) - B( J, J ) = -B( J, J ) + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 20 JR = 1, N @@ -366,9 +368,9 @@ 20 CONTINUE END IF END IF - ALPHAR( J ) = A( J, J ) + ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO - BETA( J ) = B( J, J ) + BETA( J ) = T( J, J ) 30 CONTINUE * * If IHI < ILO, skip QZ steps @@ -408,8 +410,8 @@ * Split the matrix if possible. * * Two tests: -* 1: A(j,j-1)=0 or j=ILO -* 2: B(j,j)=0 +* 1: H(j,j-1)=0 or j=ILO +* 2: T(j,j)=0 * IF( ILAST.EQ.ILO ) THEN * @@ -417,14 +419,14 @@ * GO TO 80 ELSE - IF( ABS( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN - A( ILAST, ILAST-1 ) = ZERO + IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = ZERO GO TO 80 END IF END IF * - IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN - B( ILAST, ILAST ) = ZERO + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = ZERO GO TO 70 END IF * @@ -432,36 +434,36 @@ * DO 60 J = ILAST - 1, ILO, -1 * -* Test 1: for A(j,j-1)=0 or j=ILO +* Test 1: for H(j,j-1)=0 or j=ILO * IF( J.EQ.ILO ) THEN ILAZRO = .TRUE. ELSE - IF( ABS( A( J, J-1 ) ).LE.ATOL ) THEN - A( J, J-1 ) = ZERO + IF( ABS( H( J, J-1 ) ).LE.ATOL ) THEN + H( J, J-1 ) = ZERO ILAZRO = .TRUE. ELSE ILAZRO = .FALSE. END IF END IF * -* Test 2: for B(j,j)=0 +* Test 2: for T(j,j)=0 * - IF( ABS( B( J, J ) ).LT.BTOL ) THEN - B( J, J ) = ZERO + IF( ABS( T( J, J ) ).LT.BTOL ) THEN + T( J, J ) = ZERO * * Test 1a: Check for 2 consecutive small subdiagonals in A * ILAZR2 = .FALSE. IF( .NOT.ILAZRO ) THEN - TEMP = ABS( A( J, J-1 ) ) - TEMP2 = ABS( A( J, J ) ) + TEMP = ABS( H( J, J-1 ) ) + TEMP2 = ABS( H( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( TEMP*( ASCALE*ABS( A( J+1, J ) ) ).LE.TEMP2* + IF( TEMP*( ASCALE*ABS( H( J+1, J ) ) ).LE.TEMP2* $ ( ASCALE*ATOL ) )ILAZR2 = .TRUE. END IF * @@ -473,21 +475,21 @@ * IF( ILAZRO .OR. ILAZR2 ) THEN DO 40 JCH = J, ILAST - 1 - TEMP = A( JCH, JCH ) - CALL SLARTG( TEMP, A( JCH+1, JCH ), C, S, - $ A( JCH, JCH ) ) - A( JCH+1, JCH ) = ZERO - CALL SROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA, - $ A( JCH+1, JCH+1 ), LDA, C, S ) - CALL SROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB, - $ B( JCH+1, JCH+1 ), LDB, C, S ) + TEMP = H( JCH, JCH ) + CALL SLARTG( TEMP, H( JCH+1, JCH ), C, S, + $ H( JCH, JCH ) ) + H( JCH+1, JCH ) = ZERO + CALL SROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH, + $ H( JCH+1, JCH+1 ), LDH, C, S ) + CALL SROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT, + $ T( JCH+1, JCH+1 ), LDT, C, S ) IF( ILQ ) $ CALL SROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) IF( ILAZR2 ) - $ A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C + $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C ILAZR2 = .FALSE. - IF( ABS( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN + IF( ABS( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN IF( JCH+1.GE.ILAST ) THEN GO TO 80 ELSE @@ -495,35 +497,35 @@ GO TO 110 END IF END IF - B( JCH+1, JCH+1 ) = ZERO + T( JCH+1, JCH+1 ) = ZERO 40 CONTINUE GO TO 70 ELSE * -* Only test 2 passed -- chase the zero to B(ILAST,ILAST) -* Then process as in the case B(ILAST,ILAST)=0 +* Only test 2 passed -- chase the zero to T(ILAST,ILAST) +* Then process as in the case T(ILAST,ILAST)=0 * DO 50 JCH = J, ILAST - 1 - TEMP = B( JCH, JCH+1 ) - CALL SLARTG( TEMP, B( JCH+1, JCH+1 ), C, S, - $ B( JCH, JCH+1 ) ) - B( JCH+1, JCH+1 ) = ZERO + TEMP = T( JCH, JCH+1 ) + CALL SLARTG( TEMP, T( JCH+1, JCH+1 ), C, S, + $ T( JCH, JCH+1 ) ) + T( JCH+1, JCH+1 ) = ZERO IF( JCH.LT.ILASTM-1 ) - $ CALL SROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB, - $ B( JCH+1, JCH+2 ), LDB, C, S ) - CALL SROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA, - $ A( JCH+1, JCH-1 ), LDA, C, S ) + $ CALL SROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT, + $ T( JCH+1, JCH+2 ), LDT, C, S ) + CALL SROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH, + $ H( JCH+1, JCH-1 ), LDH, C, S ) IF( ILQ ) $ CALL SROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) - TEMP = A( JCH+1, JCH ) - CALL SLARTG( TEMP, A( JCH+1, JCH-1 ), C, S, - $ A( JCH+1, JCH ) ) - A( JCH+1, JCH-1 ) = ZERO - CALL SROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1, - $ A( IFRSTM, JCH-1 ), 1, C, S ) - CALL SROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1, - $ B( IFRSTM, JCH-1 ), 1, C, S ) + TEMP = H( JCH+1, JCH ) + CALL SLARTG( TEMP, H( JCH+1, JCH-1 ), C, S, + $ H( JCH+1, JCH ) ) + H( JCH+1, JCH-1 ) = ZERO + CALL SROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1, + $ H( IFRSTM, JCH-1 ), 1, C, S ) + CALL SROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1, + $ T( IFRSTM, JCH-1 ), 1, C, S ) IF( ILZ ) $ CALL SROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, $ C, S ) @@ -547,34 +549,34 @@ INFO = N + 1 GO TO 420 * -* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a +* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a * 1x1 block. * 70 CONTINUE - TEMP = A( ILAST, ILAST ) - CALL SLARTG( TEMP, A( ILAST, ILAST-1 ), C, S, - $ A( ILAST, ILAST ) ) - A( ILAST, ILAST-1 ) = ZERO - CALL SROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1, - $ A( IFRSTM, ILAST-1 ), 1, C, S ) - CALL SROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1, - $ B( IFRSTM, ILAST-1 ), 1, C, S ) + TEMP = H( ILAST, ILAST ) + CALL SLARTG( TEMP, H( ILAST, ILAST-1 ), C, S, + $ H( ILAST, ILAST ) ) + H( ILAST, ILAST-1 ) = ZERO + CALL SROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1, + $ H( IFRSTM, ILAST-1 ), 1, C, S ) + CALL SROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1, + $ T( IFRSTM, ILAST-1 ), 1, C, S ) IF( ILZ ) $ CALL SROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S ) * -* A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, +* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, * and BETA * 80 CONTINUE - IF( B( ILAST, ILAST ).LT.ZERO ) THEN + IF( T( ILAST, ILAST ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 90 J = IFRSTM, ILAST - A( J, ILAST ) = -A( J, ILAST ) - B( J, ILAST ) = -B( J, ILAST ) + H( J, ILAST ) = -H( J, ILAST ) + T( J, ILAST ) = -T( J, ILAST ) 90 CONTINUE ELSE - A( ILAST, ILAST ) = -A( ILAST, ILAST ) - B( ILAST, ILAST ) = -B( ILAST, ILAST ) + H( ILAST, ILAST ) = -H( ILAST, ILAST ) + T( ILAST, ILAST ) = -T( ILAST, ILAST ) END IF IF( ILZ ) THEN DO 100 J = 1, N @@ -582,9 +584,9 @@ 100 CONTINUE END IF END IF - ALPHAR( ILAST ) = A( ILAST, ILAST ) + ALPHAR( ILAST ) = H( ILAST, ILAST ) ALPHAI( ILAST ) = ZERO - BETA( ILAST ) = B( ILAST, ILAST ) + BETA( ILAST ) = T( ILAST, ILAST ) * * Go to next block -- exit if finished. * @@ -617,7 +619,7 @@ * Compute single shifts. * * At this point, IFIRST < ILAST, and the diagonal elements of -* B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in +* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in * magnitude) * IF( ( IITER / 10 )*10.EQ.IITER ) THEN @@ -625,10 +627,10 @@ * Exceptional shift. Chosen for no particularly good reason. * (Single shift only.) * - IF( ( REAL( MAXIT )*SAFMIN )*ABS( A( ILAST-1, ILAST ) ).LT. - $ ABS( B( ILAST-1, ILAST-1 ) ) ) THEN - ESHIFT = ESHIFT + A( ILAST-1, ILAST ) / - $ B( ILAST-1, ILAST-1 ) + IF( ( REAL( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT. + $ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN + ESHIFT = ESHIFT + H( ILAST-1, ILAST ) / + $ T( ILAST-1, ILAST-1 ) ELSE ESHIFT = ESHIFT + ONE / ( SAFMIN*REAL( MAXIT ) ) END IF @@ -641,8 +643,8 @@ * bottom-right 2x2 block of A and B. The first eigenvalue * returned by SLAG2 is the Wilkinson shift (AEP p.512), * - CALL SLAG2( A( ILAST-1, ILAST-1 ), LDA, - $ B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, + CALL SLAG2( H( ILAST-1, ILAST-1 ), LDH, + $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ S2, WR, WR2, WI ) * TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) ) @@ -669,14 +671,14 @@ * DO 120 J = ILAST - 1, IFIRST + 1, -1 ISTART = J - TEMP = ABS( S1*A( J, J-1 ) ) - TEMP2 = ABS( S1*A( J, J )-WR*B( J, J ) ) + TEMP = ABS( S1*H( J, J-1 ) ) + TEMP2 = ABS( S1*H( J, J )-WR*T( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( ABS( ( ASCALE*A( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* + IF( ABS( ( ASCALE*H( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* $ TEMP2 )GO TO 130 120 CONTINUE * @@ -687,26 +689,26 @@ * * Initial Q * - TEMP = S1*A( ISTART, ISTART ) - WR*B( ISTART, ISTART ) - TEMP2 = S1*A( ISTART+1, ISTART ) + TEMP = S1*H( ISTART, ISTART ) - WR*T( ISTART, ISTART ) + TEMP2 = S1*H( ISTART+1, ISTART ) CALL SLARTG( TEMP, TEMP2, C, S, TEMPR ) * * Sweep * DO 190 J = ISTART, ILAST - 1 IF( J.GT.ISTART ) THEN - TEMP = A( J, J-1 ) - CALL SLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = ZERO + TEMP = H( J, J-1 ) + CALL SLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO END IF * DO 140 JC = J, ILASTM - TEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = TEMP - TEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = TEMP2 + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 140 CONTINUE IF( ILQ ) THEN DO 150 JR = 1, N @@ -716,19 +718,19 @@ 150 CONTINUE END IF * - TEMP = B( J+1, J+1 ) - CALL SLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = ZERO + TEMP = T( J+1, J+1 ) + CALL SLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO * DO 160 JR = IFRSTM, MIN( J+2, ILAST ) - TEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = TEMP + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP 160 CONTINUE DO 170 JR = IFRSTM, J - TEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = TEMP + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP 170 CONTINUE IF( ILZ ) THEN DO 180 JR = 1, N @@ -759,8 +761,8 @@ * B = ( ) with B11 non-negative. * ( 0 B22 ) * - CALL SLASV2( B( ILAST-1, ILAST-1 ), B( ILAST-1, ILAST ), - $ B( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) + CALL SLASV2( T( ILAST-1, ILAST-1 ), T( ILAST-1, ILAST ), + $ T( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) * IF( B11.LT.ZERO ) THEN CR = -CR @@ -769,17 +771,17 @@ B22 = -B22 END IF * - CALL SROT( ILASTM+1-IFIRST, A( ILAST-1, ILAST-1 ), LDA, - $ A( ILAST, ILAST-1 ), LDA, CL, SL ) - CALL SROT( ILAST+1-IFRSTM, A( IFRSTM, ILAST-1 ), 1, - $ A( IFRSTM, ILAST ), 1, CR, SR ) + CALL SROT( ILASTM+1-IFIRST, H( ILAST-1, ILAST-1 ), LDH, + $ H( ILAST, ILAST-1 ), LDH, CL, SL ) + CALL SROT( ILAST+1-IFRSTM, H( IFRSTM, ILAST-1 ), 1, + $ H( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILAST.LT.ILASTM ) - $ CALL SROT( ILASTM-ILAST, B( ILAST-1, ILAST+1 ), LDB, - $ B( ILAST, ILAST+1 ), LDA, CL, SL ) + $ CALL SROT( ILASTM-ILAST, T( ILAST-1, ILAST+1 ), LDT, + $ T( ILAST, ILAST+1 ), LDH, CL, SL ) IF( IFRSTM.LT.ILAST-1 ) - $ CALL SROT( IFIRST-IFRSTM, B( IFRSTM, ILAST-1 ), 1, - $ B( IFRSTM, ILAST ), 1, CR, SR ) + $ CALL SROT( IFIRST-IFRSTM, T( IFRSTM, ILAST-1 ), 1, + $ T( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILQ ) $ CALL SROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL, @@ -788,17 +790,17 @@ $ CALL SROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR, $ SR ) * - B( ILAST-1, ILAST-1 ) = B11 - B( ILAST-1, ILAST ) = ZERO - B( ILAST, ILAST-1 ) = ZERO - B( ILAST, ILAST ) = B22 + T( ILAST-1, ILAST-1 ) = B11 + T( ILAST-1, ILAST ) = ZERO + T( ILAST, ILAST-1 ) = ZERO + T( ILAST, ILAST ) = B22 * * If B22 is negative, negate column ILAST * IF( B22.LT.ZERO ) THEN DO 210 J = IFRSTM, ILAST - A( J, ILAST ) = -A( J, ILAST ) - B( J, ILAST ) = -B( J, ILAST ) + H( J, ILAST ) = -H( J, ILAST ) + T( J, ILAST ) = -T( J, ILAST ) 210 CONTINUE * IF( ILZ ) THEN @@ -812,8 +814,8 @@ * * Recompute shift * - CALL SLAG2( A( ILAST-1, ILAST-1 ), LDA, - $ B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, + CALL SLAG2( H( ILAST-1, ILAST-1 ), LDH, + $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ TEMP, WR, TEMP2, WI ) * * If standardization has perturbed the shift onto real line, @@ -825,10 +827,10 @@ * * Do EISPACK (QZVAL) computation of alpha and beta * - A11 = A( ILAST-1, ILAST-1 ) - A21 = A( ILAST, ILAST-1 ) - A12 = A( ILAST-1, ILAST ) - A22 = A( ILAST, ILAST ) + A11 = H( ILAST-1, ILAST-1 ) + A21 = H( ILAST, ILAST-1 ) + A12 = H( ILAST-1, ILAST ) + A22 = H( ILAST, ILAST ) * * Compute complex Givens rotation on right * (Assume some element of C = (sA - wB) > unfl ) @@ -845,10 +847,10 @@ * IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ $ ABS( C22R )+ABS( C22I ) ) THEN - T = SLAPY3( C12, C11R, C11I ) - CZ = C12 / T - SZR = -C11R / T - SZI = -C11I / T + T1 = SLAPY3( C12, C11R, C11I ) + CZ = C12 / T1 + SZR = -C11R / T1 + SZI = -C11I / T1 ELSE CZ = SLAPY2( C22R, C22I ) IF( CZ.LE.SAFMIN ) THEN @@ -858,10 +860,10 @@ ELSE TEMPR = C22R / CZ TEMPI = C22I / CZ - T = SLAPY2( CZ, C21 ) - CZ = CZ / T - SZR = -C21*TEMPR / T - SZI = C21*TEMPI / T + T1 = SLAPY2( CZ, C21 ) + CZ = CZ / T1 + SZR = -C21*TEMPR / T1 + SZI = C21*TEMPI / T1 END IF END IF * @@ -895,10 +897,10 @@ SQI = TEMPI*A2R - TEMPR*A2I END IF END IF - T = SLAPY3( CQ, SQR, SQI ) - CQ = CQ / T - SQR = SQR / T - SQI = SQI / T + T1 = SLAPY3( CQ, SQR, SQI ) + CQ = CQ / T1 + SQR = SQR / T1 + SQI = SQI / T1 * * Compute diagonal elements of QBZ * @@ -950,26 +952,26 @@ * * We assume that the block is at least 3x3 * - AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD22 = ( ASCALE*A( ILAST, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - U12 = B( ILAST-1, ILAST ) / B( ILAST, ILAST ) - AD11L = ( ASCALE*A( IFIRST, IFIRST ) ) / - $ ( BSCALE*B( IFIRST, IFIRST ) ) - AD21L = ( ASCALE*A( IFIRST+1, IFIRST ) ) / - $ ( BSCALE*B( IFIRST, IFIRST ) ) - AD12L = ( ASCALE*A( IFIRST, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - AD22L = ( ASCALE*A( IFIRST+1, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - AD32L = ( ASCALE*A( IFIRST+2, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - U12L = B( IFIRST, IFIRST+1 ) / B( IFIRST+1, IFIRST+1 ) + AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD22 = ( ASCALE*H( ILAST, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) + AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) * V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L @@ -991,27 +993,27 @@ * Zero (j-1)st column of A * IF( J.GT.ISTART ) THEN - V( 1 ) = A( J, J-1 ) - V( 2 ) = A( J+1, J-1 ) - V( 3 ) = A( J+2, J-1 ) + V( 1 ) = H( J, J-1 ) + V( 2 ) = H( J+1, J-1 ) + V( 3 ) = H( J+2, J-1 ) * - CALL SLARFG( 3, A( J, J-1 ), V( 2 ), 1, TAU ) + CALL SLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE - A( J+1, J-1 ) = ZERO - A( J+2, J-1 ) = ZERO + H( J+1, J-1 ) = ZERO + H( J+2, J-1 ) = ZERO END IF * DO 230 JC = J, ILASTM - TEMP = TAU*( A( J, JC )+V( 2 )*A( J+1, JC )+V( 3 )* - $ A( J+2, JC ) ) - A( J, JC ) = A( J, JC ) - TEMP - A( J+1, JC ) = A( J+1, JC ) - TEMP*V( 2 ) - A( J+2, JC ) = A( J+2, JC ) - TEMP*V( 3 ) - TEMP2 = TAU*( B( J, JC )+V( 2 )*B( J+1, JC )+V( 3 )* - $ B( J+2, JC ) ) - B( J, JC ) = B( J, JC ) - TEMP2 - B( J+1, JC ) = B( J+1, JC ) - TEMP2*V( 2 ) - B( J+2, JC ) = B( J+2, JC ) - TEMP2*V( 3 ) + TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* + $ H( J+2, JC ) ) + H( J, JC ) = H( J, JC ) - TEMP + H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) + H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) + TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* + $ T( J+2, JC ) ) + T( J, JC ) = T( J, JC ) - TEMP2 + T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) + T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) 230 CONTINUE IF( ILQ ) THEN DO 240 JR = 1, N @@ -1028,27 +1030,27 @@ * Swap rows to pivot * ILPIVT = .FALSE. - TEMP = MAX( ABS( B( J+1, J+1 ) ), ABS( B( J+1, J+2 ) ) ) - TEMP2 = MAX( ABS( B( J+2, J+1 ) ), ABS( B( J+2, J+2 ) ) ) + TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) + TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN SCALE = ZERO U1 = ONE U2 = ZERO GO TO 250 ELSE IF( TEMP.GE.TEMP2 ) THEN - W11 = B( J+1, J+1 ) - W21 = B( J+2, J+1 ) - W12 = B( J+1, J+2 ) - W22 = B( J+2, J+2 ) - U1 = B( J+1, J ) - U2 = B( J+2, J ) + W11 = T( J+1, J+1 ) + W21 = T( J+2, J+1 ) + W12 = T( J+1, J+2 ) + W22 = T( J+2, J+2 ) + U1 = T( J+1, J ) + U2 = T( J+2, J ) ELSE - W21 = B( J+1, J+1 ) - W11 = B( J+2, J+1 ) - W22 = B( J+1, J+2 ) - W12 = B( J+2, J+2 ) - U2 = B( J+1, J ) - U1 = B( J+2, J ) + W21 = T( J+1, J+1 ) + W11 = T( J+2, J+1 ) + W22 = T( J+1, J+2 ) + W12 = T( J+2, J+2 ) + U2 = T( J+1, J ) + U1 = T( J+2, J ) END IF * * Swap columns if nec. @@ -1098,9 +1100,9 @@ * * Compute Householder Vector * - T = SQRT( SCALE**2+U1**2+U2**2 ) - TAU = ONE + SCALE / T - VS = -ONE / ( SCALE+T ) + T1 = SQRT( SCALE**2+U1**2+U2**2 ) + TAU = ONE + SCALE / T1 + VS = -ONE / ( SCALE+T1 ) V( 1 ) = ONE V( 2 ) = VS*U1 V( 3 ) = VS*U2 @@ -1108,18 +1110,18 @@ * Apply transformations from the right. * DO 260 JR = IFRSTM, MIN( J+3, ILAST ) - TEMP = TAU*( A( JR, J )+V( 2 )*A( JR, J+1 )+V( 3 )* - $ A( JR, J+2 ) ) - A( JR, J ) = A( JR, J ) - TEMP - A( JR, J+1 ) = A( JR, J+1 ) - TEMP*V( 2 ) - A( JR, J+2 ) = A( JR, J+2 ) - TEMP*V( 3 ) + TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* + $ H( JR, J+2 ) ) + H( JR, J ) = H( JR, J ) - TEMP + H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) + H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) 260 CONTINUE DO 270 JR = IFRSTM, J + 2 - TEMP = TAU*( B( JR, J )+V( 2 )*B( JR, J+1 )+V( 3 )* - $ B( JR, J+2 ) ) - B( JR, J ) = B( JR, J ) - TEMP - B( JR, J+1 ) = B( JR, J+1 ) - TEMP*V( 2 ) - B( JR, J+2 ) = B( JR, J+2 ) - TEMP*V( 3 ) + TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* + $ T( JR, J+2 ) ) + T( JR, J ) = T( JR, J ) - TEMP + T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) + T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) 270 CONTINUE IF( ILZ ) THEN DO 280 JR = 1, N @@ -1130,8 +1132,8 @@ Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) 280 CONTINUE END IF - B( J+1, J ) = ZERO - B( J+2, J ) = ZERO + T( J+1, J ) = ZERO + T( J+2, J ) = ZERO 290 CONTINUE * * Last elements: Use Givens rotations @@ -1139,17 +1141,17 @@ * Rotations from the left * J = ILAST - 1 - TEMP = A( J, J-1 ) - CALL SLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = ZERO + TEMP = H( J, J-1 ) + CALL SLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO * DO 300 JC = J, ILASTM - TEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = TEMP - TEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = TEMP2 + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 300 CONTINUE IF( ILQ ) THEN DO 310 JR = 1, N @@ -1161,19 +1163,19 @@ * * Rotations from the right. * - TEMP = B( J+1, J+1 ) - CALL SLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = ZERO + TEMP = T( J+1, J+1 ) + CALL SLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO * DO 320 JR = IFRSTM, ILAST - TEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = TEMP + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP 320 CONTINUE DO 330 JR = IFRSTM, ILAST - 1 - TEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = TEMP + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP 330 CONTINUE IF( ILZ ) THEN DO 340 JR = 1, N @@ -1207,15 +1209,15 @@ * Set Eigenvalues 1:ILO-1 * DO 410 J = 1, ILO - 1 - IF( B( J, J ).LT.ZERO ) THEN + IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 390 JR = 1, J - A( JR, J ) = -A( JR, J ) - B( JR, J ) = -B( JR, J ) + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) 390 CONTINUE ELSE - A( J, J ) = -A( J, J ) - B( J, J ) = -B( J, J ) + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 400 JR = 1, N @@ -1223,9 +1225,9 @@ 400 CONTINUE END IF END IF - ALPHAR( J ) = A( J, J ) + ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO - BETA( J ) = B( J, J ) + BETA( J ) = T( J, J ) 410 CONTINUE * * Normal Termination diff -uNr LAPACK.orig/SRC/slasr.f LAPACK/SRC/slasr.f --- LAPACK.orig/SRC/slasr.f Thu Nov 4 14:23:40 1999 +++ LAPACK/SRC/slasr.f Fri May 25 16:12:26 2001 @@ -3,7 +3,7 @@ * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* May 3, 2001 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE @@ -16,44 +16,77 @@ * Purpose * ======= * -* SLASR performs the transformation -* -* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) -* -* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) -* -* where A is an m by n real matrix and P is an orthogonal matrix, -* consisting of a sequence of plane rotations determined by the -* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' -* and z = n when SIDE = 'R' or 'r' ): -* -* When DIRECT = 'F' or 'f' ( Forward sequence ) then -* -* P = P( z - 1 )*...*P( 2 )*P( 1 ), -* -* and when DIRECT = 'B' or 'b' ( Backward sequence ) then -* -* P = P( 1 )*P( 2 )*...*P( z - 1 ), -* -* where P( k ) is a plane rotation matrix for the following planes: -* -* when PIVOT = 'V' or 'v' ( Variable pivot ), -* the plane ( k, k + 1 ) -* -* when PIVOT = 'T' or 't' ( Top pivot ), -* the plane ( 1, k + 1 ) -* -* when PIVOT = 'B' or 'b' ( Bottom pivot ), -* the plane ( k, z ) -* -* c( k ) and s( k ) must contain the cosine and sine that define the -* matrix P( k ). The two by two plane rotation part of the matrix -* P( k ), R( k ), is assumed to be of the form -* -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) -* -* This version vectorises across rows of the array A when SIDE = 'L'. +* SLASR applies a sequence of plane rotations to a real 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 * ========= @@ -62,13 +95,13 @@ * 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' +* = 'R': Right, compute A:= A*P**T * * 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 ) +* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) +* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation @@ -85,18 +118,22 @@ * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * -* C, S (input) REAL arrays, dimension +* C (input) REAL array, dimension +* (M-1) if SIDE = 'L' +* (N-1) if SIDE = 'R' +* The cosines c(k) of the plane rotations. +* +* S (input) REAL array, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' -* c(k) and s(k) contain the cosine and sine that define the -* matrix P(k). The two by two plane rotation part of the -* matrix P(k), R(k), is assumed to be of the form -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) +* 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) REAL array, dimension (LDA,N) -* The m by n matrix A. On exit, A is overwritten by P*A if -* SIDE = 'R' or by A*P' if SIDE = 'L'. +* 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). diff -uNr LAPACK.orig/SRC/ssbgst.f LAPACK/SRC/ssbgst.f --- LAPACK.orig/SRC/ssbgst.f Thu Nov 4 14:23:32 1999 +++ LAPACK/SRC/ssbgst.f Fri May 25 16:12:46 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* January 9, 2001 * * .. Scalar Arguments .. CHARACTER UPLO, VECT @@ -125,7 +125,7 @@ INFO = -3 ELSE IF( KA.LT.0 ) THEN INFO = -4 - ELSE IF( KB.LT.0 ) THEN + ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN INFO = -5 ELSE IF( LDAB.LT.KA+1 ) THEN INFO = -7 diff -uNr LAPACK.orig/SRC/sstebz.f LAPACK/SRC/sstebz.f --- LAPACK.orig/SRC/sstebz.f Thu Nov 4 14:24:00 1999 +++ LAPACK/SRC/sstebz.f Fri May 25 16:13:18 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-18-00: Increase FUDGE factor for T3E (eca) * * .. Scalar Arguments .. CHARACTER ORDER, RANGE @@ -175,7 +176,7 @@ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, $ HALF = 1.0E0 / TWO ) REAL FUDGE, RELFAC - PARAMETER ( FUDGE = 2.0E0, RELFAC = 2.0E0 ) + PARAMETER ( FUDGE = 2.1E0, RELFAC = 2.0E0 ) * .. * .. Local Scalars .. LOGICAL NCNVRG, TOOFEW diff -uNr LAPACK.orig/SRC/stgevc.f LAPACK/SRC/stgevc.f --- LAPACK.orig/SRC/stgevc.f Thu Nov 4 14:26:09 1999 +++ LAPACK/SRC/stgevc.f Fri May 25 16:13:28 2001 @@ -1,18 +1,18 @@ - SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, + SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 4, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE - INTEGER INFO, LDA, LDB, LDVL, LDVR, M, MM, N + INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) - REAL A( LDA, * ), B( LDB, * ), VL( LDVL, * ), + REAL P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * @@ -20,34 +20,30 @@ * Purpose * ======= * -* STGEVC computes some or all of the right and/or left generalized -* eigenvectors of a pair of real upper triangular matrices (A,B). -* -* The right generalized eigenvector x and the left generalized -* eigenvector y of (A,B) corresponding to a generalized eigenvalue -* w are defined by: -* -* (A - wB) * x = 0 and y**H * (A - wB) = 0 -* +* STGEVC computes some or all of the right and/or left eigenvectors of +* a pair of real matrices (S,P), where S is a quasi-triangular matrix +* and P is upper triangular. Matrix pairs of this type are produced by +* the generalized Schur factorization of a matrix pair (A,B): +* +* A = Q*S*Z**T, B = Q*P*Z**T +* +* as computed by SGGHRD + SHGEQZ. +* +* The right eigenvector x and the left eigenvector y of (S,P) +* corresponding to an eigenvalue w are defined by: +* +* S*x = w*P*x, (y**H)*S = w*(y**H)*P, +* * where y**H denotes the conjugate tranpose of y. -* -* If an eigenvalue w is determined by zero diagonal elements of both A -* and B, a unit vector is returned as the corresponding eigenvector. -* -* If all eigenvectors are requested, the routine may either return -* the matrices X and/or Y of right or left eigenvectors of (A,B), or -* the products Z*X and/or Q*Y, where Z and Q are input orthogonal -* matrices. If (A,B) was obtained from the generalized real-Schur -* factorization of an original pair of matrices -* (A0,B0) = (Q*A*Z**H,Q*B*Z**H), -* then Z*X and Q*Y are the matrices of right or left eigenvectors of -* A. -* -* A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal -* blocks. Corresponding to each 2-by-2 diagonal block is a complex -* conjugate pair of eigenvalues and eigenvectors; only one -* eigenvector of the pair is computed, namely the one corresponding -* to the eigenvalue with positive imaginary part. +* The eigenvalues are not input to this routine, but are computed +* directly from the diagonal blocks of S and P. +* +* This routine returns the matrices X and/or Y of right and left +* eigenvectors of (S,P), or the products Z*X and/or Q*Y, +* where Z and Q are input matrices. +* If Q and Z are the orthogonal factors from the generalized Schur +* factorization of a matrix pair (A,B), then Z*X and Q*Y +* are the matrices of right and left eigenvectors of (A,B). * * Arguments * ========= @@ -59,78 +55,84 @@ * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; -* = 'B': compute all right and/or left eigenvectors, and -* backtransform them using the input matrices supplied -* in VR and/or VL; +* = 'B': compute all right and/or left eigenvectors, +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY='S', SELECT specifies the eigenvectors to be -* computed. -* If HOWMNY='A' or 'B', SELECT is not referenced. -* To select the real eigenvector corresponding to the real -* eigenvalue w(j), SELECT(j) must be set to .TRUE. To select -* the complex eigenvector corresponding to a complex conjugate -* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must -* be set to .TRUE.. +* computed. If w(j) is a real eigenvalue, the corresponding +* real eigenvector is computed if SELECT(j) is .TRUE.. +* If w(j) and w(j+1) are the real and imaginary parts of a +* complex eigenvalue, the corresponding complex eigenvector +* is computed if either SELECT(j) or SELECT(j+1) is .TRUE., +* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is +* set to .FALSE.. +* Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER -* The order of the matrices A and B. N >= 0. +* The order of the matrices S and P. N >= 0. * -* A (input) REAL array, dimension (LDA,N) -* The upper quasi-triangular matrix A. +* S (input) REAL array, dimension (LDS,N) +* The upper quasi-triangular matrix S from a generalized Schur +* factorization, as computed by SHGEQZ. +* +* LDS (input) INTEGER +* The leading dimension of array S. LDS >= max(1,N). +* +* P (input) REAL array, dimension (LDP,N) +* The upper triangular matrix P from a generalized Schur +* factorization, as computed by SHGEQZ. +* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks +* of S must be in positive diagonal form. * -* LDA (input) INTEGER -* The leading dimension of array A. LDA >= max(1, N). -* -* B (input) REAL array, dimension (LDB,N) -* The upper triangular matrix B. If A has a 2-by-2 diagonal -* block, then the corresponding 2-by-2 block of B must be -* diagonal with positive elements. -* -* LDB (input) INTEGER -* The leading dimension of array B. LDB >= max(1,N). +* LDP (input) INTEGER +* The leading dimension of array P. LDP >= max(1,N). * * VL (input/output) REAL array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of left Schur vectors returned by SHGEQZ). * On exit, if SIDE = 'L' or 'B', VL contains: -* if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Q*Y; -* if HOWMNY = 'S', the left eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VL, in the same order as their eigenvalues. -* If SIDE = 'R', VL is not referenced. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. * +* Not referenced if SIDE = 'R'. +* * LDVL (input) INTEGER -* The leading dimension of array VL. -* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) REAL array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must -* contain an N-by-N matrix Q (usually the orthogonal matrix Z +* contain an N-by-N matrix Z (usually the orthogonal matrix Z * of right Schur vectors returned by SHGEQZ). +* * On exit, if SIDE = 'R' or 'B', VR contains: -* if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); -* if HOWMNY = 'B', the matrix Z*X; -* if HOWMNY = 'S', the right eigenvectors of (A,B) specified by -* SELECT, stored consecutively in the columns of -* VR, in the same order as their eigenvalues. -* If SIDE = 'L', VR is not referenced. +* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); +* if HOWMNY = 'B' or 'b', the matrix Z*X; +* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) +* specified by SELECT, stored consecutively in the +* columns of VR, in the same order as their +* eigenvalues. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. +* +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. -* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. @@ -199,7 +201,7 @@ * partial sums. Since FORTRAN arrays are stored columnwise, this has * the advantage that at each step, the elements of C that are accessed * are adjacent to one another, whereas with the rowwise method, the -* elements accessed at a step are spaced LDA (and LDB) words apart. +* elements accessed at a step are spaced LDS (and LDP) words apart. * * When finding left eigenvectors, the matrix in question is the * transpose of the one in storage, so the rowwise method then @@ -226,8 +228,8 @@ $ XSCALE * .. * .. Local Arrays .. - REAL BDIAG( 2 ), SUM( 2, 2 ), SUMA( 2, 2 ), - $ SUMB( 2, 2 ) + REAL BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ), + $ SUMP( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME @@ -252,7 +254,7 @@ IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. - ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN + ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. @@ -284,9 +286,9 @@ INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN @@ -305,7 +307,7 @@ GO TO 10 END IF IF( J.LT.N ) THEN - IF( A( J+1, J ).NE.ZERO ) + IF( S( J+1, J ).NE.ZERO ) $ ILCPLX = .TRUE. END IF IF( ILCPLX ) THEN @@ -325,11 +327,11 @@ ILABAD = .FALSE. ILBBAD = .FALSE. DO 20 J = 1, N - 1 - IF( A( J+1, J ).NE.ZERO ) THEN - IF( B( J, J ).EQ.ZERO .OR. B( J+1, J+1 ).EQ.ZERO .OR. - $ B( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. + IF( S( J+1, J ).NE.ZERO ) THEN + IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR. + $ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. IF( J.LT.N-1 ) THEN - IF( A( J+2, J+1 ).NE.ZERO ) + IF( S( J+2, J+1 ).NE.ZERO ) $ ILABAD = .TRUE. END IF END IF @@ -372,30 +374,30 @@ * blocks) of A and B to check for possible overflow in the * triangular solver. * - ANORM = ABS( A( 1, 1 ) ) + ANORM = ABS( S( 1, 1 ) ) IF( N.GT.1 ) - $ ANORM = ANORM + ABS( A( 2, 1 ) ) - BNORM = ABS( B( 1, 1 ) ) + $ ANORM = ANORM + ABS( S( 2, 1 ) ) + BNORM = ABS( P( 1, 1 ) ) WORK( 1 ) = ZERO WORK( N+1 ) = ZERO * DO 50 J = 2, N TEMP = ZERO TEMP2 = ZERO - IF( A( J, J-1 ).EQ.ZERO ) THEN + IF( S( J, J-1 ).EQ.ZERO ) THEN IEND = J - 1 ELSE IEND = J - 2 END IF DO 30 I = 1, IEND - TEMP = TEMP + ABS( A( I, J ) ) - TEMP2 = TEMP2 + ABS( B( I, J ) ) + TEMP = TEMP + ABS( S( I, J ) ) + TEMP2 = TEMP2 + ABS( P( I, J ) ) 30 CONTINUE WORK( J ) = TEMP WORK( N+J ) = TEMP2 DO 40 I = IEND + 1, MIN( J+1, N ) - TEMP = TEMP + ABS( A( I, J ) ) - TEMP2 = TEMP2 + ABS( B( I, J ) ) + TEMP = TEMP + ABS( S( I, J ) ) + TEMP2 = TEMP2 + ABS( P( I, J ) ) 40 CONTINUE ANORM = MAX( ANORM, TEMP ) BNORM = MAX( BNORM, TEMP2 ) @@ -425,7 +427,7 @@ END IF NW = 1 IF( JE.LT.N ) THEN - IF( A( JE+1, JE ).NE.ZERO ) THEN + IF( S( JE+1, JE ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF @@ -444,8 +446,8 @@ * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN - IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN + IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * @@ -472,10 +474,10 @@ * * Real eigenvalue * - TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, - $ ABS( B( JE, JE ) )*BSCALE, SAFMIN ) - SALFAR = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*B( JE, JE ) )*BSCALE + TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, + $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) + SALFAR = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO @@ -517,7 +519,7 @@ * * Complex eigenvalue * - CALL SLAG2( A( JE, JE ), LDA, B( JE, JE ), LDB, + CALL SLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) BCOEFI = -BCOEFI @@ -549,9 +551,9 @@ * * Compute first two components of eigenvector * - TEMP = ACOEF*A( JE+1, JE ) - TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE ) - TEMP2I = -BCOEFI*B( JE, JE ) + TEMP = ACOEF*S( JE+1, JE ) + TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) + TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO @@ -560,10 +562,10 @@ ELSE WORK( 2*N+JE+1 ) = ONE WORK( 3*N+JE+1 ) = ZERO - TEMP = ACOEF*A( JE, JE+1 ) - WORK( 2*N+JE ) = ( BCOEFR*B( JE+1, JE+1 )-ACOEF* - $ A( JE+1, JE+1 ) ) / TEMP - WORK( 3*N+JE ) = BCOEFI*B( JE+1, JE+1 ) / TEMP + TEMP = ACOEF*S( JE, JE+1 ) + WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF* + $ S( JE+1, JE+1 ) ) / TEMP + WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP END IF XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) ) @@ -586,11 +588,11 @@ END IF * NA = 1 - BDIAG( 1 ) = B( J, J ) + BDIAG( 1 ) = P( J, J ) IF( J.LT.N ) THEN - IF( A( J+1, J ).NE.ZERO ) THEN + IF( S( J+1, J ).NE.ZERO ) THEN IL2BY2 = .TRUE. - BDIAG( 2 ) = B( J+1, J+1 ) + BDIAG( 2 ) = P( J+1, J+1 ) NA = 2 END IF END IF @@ -616,13 +618,13 @@ * Compute dot products * * j-1 -* SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) +* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * * To reduce the op count, this is done as * * _ j-1 _ j-1 -* a*conjg( sum A(k,j)*x(k) ) - b*conjg( sum B(k,j)*x(k) ) +* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) * k=je k=je * * which may cause underflow problems if A or B are close @@ -659,15 +661,15 @@ *$PL$ CMCHAR='*' * DO 110 JA = 1, NA - SUMA( JA, JW ) = ZERO - SUMB( JA, JW ) = ZERO + SUMS( JA, JW ) = ZERO + SUMP( JA, JW ) = ZERO * DO 100 JR = JE, J - 1 - SUMA( JA, JW ) = SUMA( JA, JW ) + - $ A( JR, J+JA-1 )* + SUMS( JA, JW ) = SUMS( JA, JW ) + + $ S( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) - SUMB( JA, JW ) = SUMB( JA, JW ) + - $ B( JR, J+JA-1 )* + SUMP( JA, JW ) = SUMP( JA, JW ) + + $ P( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) 100 CONTINUE 110 CONTINUE @@ -687,15 +689,15 @@ * DO 130 JA = 1, NA IF( ILCPLX ) THEN - SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + - $ BCOEFR*SUMB( JA, 1 ) - - $ BCOEFI*SUMB( JA, 2 ) - SUM( JA, 2 ) = -ACOEF*SUMA( JA, 2 ) + - $ BCOEFR*SUMB( JA, 2 ) + - $ BCOEFI*SUMB( JA, 1 ) + SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + + $ BCOEFR*SUMP( JA, 1 ) - + $ BCOEFI*SUMP( JA, 2 ) + SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) + + $ BCOEFR*SUMP( JA, 2 ) + + $ BCOEFI*SUMP( JA, 1 ) ELSE - SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + - $ BCOEFR*SUMB( JA, 1 ) + SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + + $ BCOEFR*SUMP( JA, 1 ) END IF 130 CONTINUE * @@ -703,7 +705,7 @@ * Solve ( a A - b B ) y = SUM(,) * with scaling and perturbation of the denominator * - CALL SLALN2( .TRUE., NA, NW, DMIN, ACOEF, A( J, J ), LDA, + CALL SLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS, $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR, $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP, $ IINFO ) @@ -790,7 +792,7 @@ END IF NW = 1 IF( JE.GT.1 ) THEN - IF( A( JE, JE-1 ).NE.ZERO ) THEN + IF( S( JE, JE-1 ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF @@ -809,8 +811,8 @@ * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN - IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN + IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- unit eigenvector * @@ -839,10 +841,10 @@ * * Real eigenvalue * - TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, - $ ABS( B( JE, JE ) )*BSCALE, SAFMIN ) - SALFAR = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*B( JE, JE ) )*BSCALE + TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, + $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) + SALFAR = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO @@ -885,14 +887,14 @@ * (See "Further Details", above.) * DO 260 JR = 1, JE - 1 - WORK( 2*N+JR ) = BCOEFR*B( JR, JE ) - - $ ACOEF*A( JR, JE ) + WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) - + $ ACOEF*S( JR, JE ) 260 CONTINUE ELSE * * Complex eigenvalue * - CALL SLAG2( A( JE-1, JE-1 ), LDA, B( JE-1, JE-1 ), LDB, + CALL SLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) IF( BCOEFI.EQ.ZERO ) THEN @@ -924,9 +926,9 @@ * Compute first two components of eigenvector * and contribution to sums * - TEMP = ACOEF*A( JE, JE-1 ) - TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE ) - TEMP2I = -BCOEFI*B( JE, JE ) + TEMP = ACOEF*S( JE, JE-1 ) + TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) + TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO @@ -935,10 +937,10 @@ ELSE WORK( 2*N+JE-1 ) = ONE WORK( 3*N+JE-1 ) = ZERO - TEMP = ACOEF*A( JE-1, JE ) - WORK( 2*N+JE ) = ( BCOEFR*B( JE-1, JE-1 )-ACOEF* - $ A( JE-1, JE-1 ) ) / TEMP - WORK( 3*N+JE ) = BCOEFI*B( JE-1, JE-1 ) / TEMP + TEMP = ACOEF*S( JE-1, JE ) + WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF* + $ S( JE-1, JE-1 ) ) / TEMP + WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP END IF * XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), @@ -958,12 +960,12 @@ CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE ) CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE ) DO 270 JR = 1, JE - 2 - WORK( 2*N+JR ) = -CREALA*A( JR, JE-1 ) + - $ CREALB*B( JR, JE-1 ) - - $ CRE2A*A( JR, JE ) + CRE2B*B( JR, JE ) - WORK( 3*N+JR ) = -CIMAGA*A( JR, JE-1 ) + - $ CIMAGB*B( JR, JE-1 ) - - $ CIM2A*A( JR, JE ) + CIM2B*B( JR, JE ) + WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) + + $ CREALB*P( JR, JE-1 ) - + $ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE ) + WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) + + $ CIMAGB*P( JR, JE-1 ) - + $ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE ) 270 CONTINUE END IF * @@ -978,23 +980,23 @@ * next iteration to process it (when it will be j:j+1) * IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN - IF( A( J, J-1 ).NE.ZERO ) THEN + IF( S( J, J-1 ).NE.ZERO ) THEN IL2BY2 = .TRUE. GO TO 370 END IF END IF - BDIAG( 1 ) = B( J, J ) + BDIAG( 1 ) = P( J, J ) IF( IL2BY2 ) THEN NA = 2 - BDIAG( 2 ) = B( J+1, J+1 ) + BDIAG( 2 ) = P( J+1, J+1 ) ELSE NA = 1 END IF * * Compute x(j) (and x(j+1), if 2-by-2 block) * - CALL SLALN2( .FALSE., NA, NW, DMIN, ACOEF, A( J, J ), - $ LDA, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), + CALL SLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ), + $ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN @@ -1014,7 +1016,7 @@ 300 CONTINUE 310 CONTINUE * -* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling +* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( J.GT.1 ) THEN * @@ -1052,19 +1054,19 @@ $ BCOEFR*WORK( 3*N+J+JA-1 ) DO 340 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - - $ CREALA*A( JR, J+JA-1 ) + - $ CREALB*B( JR, J+JA-1 ) + $ CREALA*S( JR, J+JA-1 ) + + $ CREALB*P( JR, J+JA-1 ) WORK( 3*N+JR ) = WORK( 3*N+JR ) - - $ CIMAGA*A( JR, J+JA-1 ) + - $ CIMAGB*B( JR, J+JA-1 ) + $ CIMAGA*S( JR, J+JA-1 ) + + $ CIMAGB*P( JR, J+JA-1 ) 340 CONTINUE ELSE CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) DO 350 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - - $ CREALA*A( JR, J+JA-1 ) + - $ CREALB*B( JR, J+JA-1 ) + $ CREALA*S( JR, J+JA-1 ) + + $ CREALB*P( JR, J+JA-1 ) 350 CONTINUE END IF 360 CONTINUE diff -uNr LAPACK.orig/SRC/strevc.f LAPACK/SRC/strevc.f --- LAPACK.orig/SRC/strevc.f Thu Nov 4 14:24:06 1999 +++ LAPACK/SRC/strevc.f Fri May 25 16:13:46 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 7, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -21,28 +21,23 @@ * * STREVC computes some or all of the right and/or left eigenvectors of * a real upper quasi-triangular matrix T. -* +* Matrices of this type are produced by the Schur factorization of +* a real general matrix: A = Q*T*Q**T, as computed by SHSEQR. +* * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: -* -* T*x = w*x, y'*T = w*y' -* -* where y' denotes the conjugate transpose of the vector y. -* -* If all eigenvectors are requested, the routine may either return the -* matrices X and/or Y of right or left eigenvectors of T, or the -* products Q*X and/or Q*Y, where Q is an input orthogonal -* matrix. If T was obtained from the real-Schur factorization of an -* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of -* right or left eigenvectors of A. -* -* T must be in Schur canonical form (as returned by SHSEQR), that is, -* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each -* 2-by-2 diagonal block has its diagonal elements equal and its -* off-diagonal elements of opposite sign. Corresponding to each 2-by-2 -* diagonal block is a complex conjugate pair of eigenvalues and -* eigenvectors; only one eigenvector of the pair is computed, namely -* the one corresponding to the eigenvalue with positive imaginary part. +* +* T*x = w*x, (y**H)*T = w*(y**H) +* +* where y**H denotes the conjugate transpose of y. +* The eigenvalues are not input to this routine, but are read directly +* from the diagonal blocks 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 orthogonal 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 * ========= @@ -55,21 +50,21 @@ * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, -* and backtransform them using the input matrices -* supplied in VR and/or VL; +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, -* specified by the logical array SELECT. +* as indicated by the logical array SELECT. * * SELECT (input/output) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. -* If HOWMNY = 'A' or 'B', SELECT is not referenced. -* To select the real eigenvector corresponding to a real -* eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select -* the complex eigenvector corresponding to a complex conjugate -* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be -* set to .TRUE.; then on exit SELECT(j) is .TRUE. and -* SELECT(j+1) is .FALSE.. +* If w(j) is a real eigenvalue, the corresponding real +* eigenvector is computed if SELECT(j) is .TRUE.. +* If w(j) and w(j+1) are the real and imaginary parts of a +* complex eigenvalue, the corresponding complex eigenvector is +* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and +* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to +* .FALSE.. +* Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER * The order of the matrix T. N >= 0. @@ -86,15 +81,6 @@ * of Schur vectors returned by SHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; -* VL has the same quasi-lower triangular form -* as T'. If T(i,i) is a real eigenvalue, then -* the i-th column VL(i) of VL is its -* corresponding eigenvector. If T(i:i+1,i:i+1) -* is a 2-by-2 block whose eigenvalues are -* complex-conjugate eigenvalues of T, then -* VL(i)+sqrt(-1)*VL(i+1) is the complex -* eigenvector corresponding to the eigenvalue -* with positive real part. * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns @@ -103,11 +89,11 @@ * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of the array VL. LDVL >= max(1,N) if -* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of the array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) REAL array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must @@ -115,15 +101,6 @@ * of Schur vectors returned by SHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; -* VR has the same quasi-upper triangular form -* as T. If T(i,i) is a real eigenvalue, then -* the i-th column VR(i) of VR is its -* corresponding eigenvector. If T(i:i+1,i:i+1) -* is a 2-by-2 block whose eigenvalues are -* complex-conjugate eigenvalues of T, then -* VR(i)+sqrt(-1)*VR(i+1) is the complex -* eigenvector corresponding to the eigenvalue -* with positive real part. * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns @@ -132,11 +109,11 @@ * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. LDVR >= max(1,N) if -* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. diff -uNr LAPACK.orig/SRC/strsen.f LAPACK/SRC/strsen.f --- LAPACK.orig/SRC/strsen.f Thu Nov 4 14:24:06 1999 +++ LAPACK/SRC/strsen.f Fri May 25 16:14:06 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* January 3, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB @@ -118,8 +118,8 @@ * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= max(1,N); -* if JOB = 'E', LWORK >= M*(N-M); -* if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). +* if JOB = 'E', LWORK >= max(1,M*(N-M)); +* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns @@ -127,12 +127,12 @@ * message related to LWORK is issued by XERBLA. * * IWORK (workspace) INTEGER array, dimension (LIWORK) -* IF JOB = 'N' or 'E', IWORK is not referenced. +* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. * * LIWORK (input) INTEGER * The dimension of the array IWORK. * If JOB = 'N' or 'E', LIWORK >= 1; -* if JOB = 'V' or 'B', LIWORK >= M*(N-M). +* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). * * If LIWORK = -1, then a workspace query is assumed; the * routine only calculates the optimal size of the IWORK array, diff -uNr LAPACK.orig/SRC/zbdsqr.f LAPACK/SRC/zbdsqr.f --- LAPACK.orig/SRC/zbdsqr.f Thu Nov 4 14:25:42 1999 +++ LAPACK/SRC/zbdsqr.f Fri May 25 15:59:12 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. CHARACTER UPLO @@ -18,14 +18,26 @@ * Purpose * ======= * -* ZBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. -* -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given complex input matrices U, VT, and C. +* 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, @@ -61,18 +73,17 @@ * order. * * E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E +* 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. E(N) is used for workspace. * * VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. +* On exit, VT is overwritten by P**H * VT. +* Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. @@ -81,21 +92,22 @@ * 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. -* U is not referenced if NRU = 0. +* 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' * C. -* C is not referenced if NCC = 0. +* 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 (4*N) +* 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 diff -uNr LAPACK.orig/SRC/zgebd2.f LAPACK/SRC/zgebd2.f --- LAPACK.orig/SRC/zgebd2.f Thu Nov 4 14:25:01 1999 +++ LAPACK/SRC/zgebd2.f Fri May 25 15:59:31 2001 @@ -3,7 +3,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* May 7, 2001 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N @@ -172,8 +172,9 @@ * * Apply H(i)' to A(i:m,i+1:n) from the left * - CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) + 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 @@ -215,8 +216,9 @@ * * Apply G(i) to A(i+1:m,i:n) from the right * - CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), - $ A( MIN( I+1, M ), I ), LDA, WORK ) + IF( I.LT.M ) + $ CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( MIN( I+1, M ), I ), LDA, WORK ) CALL ZLACGV( N-I+1, A( I, I ), LDA ) A( I, I ) = D( I ) * diff -uNr LAPACK.orig/SRC/zgees.f LAPACK/SRC/zgees.f --- LAPACK.orig/SRC/zgees.f Thu Nov 4 14:25:01 1999 +++ LAPACK/SRC/zgees.f Fri May 25 16:00:01 2001 @@ -5,6 +5,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVS, SORT @@ -89,10 +90,9 @@ * 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. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) DOUBLE PRECISION array, dimension (N) * @@ -120,11 +120,13 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, SCALEA, WANTST, WANTVS + LOGICAL SCALEA, WANTST, WANTVS INTEGER HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO, $ ITAU, IWRK, K, MAXB, MAXWRK, MINWRK DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM @@ -133,8 +135,8 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD, ZHSEQR, - $ ZLACPY, ZLASCL, ZTRSEN, ZUNGHR + EXTERNAL DLABAD, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD, + $ ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME @@ -150,7 +152,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) WANTVS = LSAME( JOBVS, 'V' ) WANTST = LSAME( SORT, 'S' ) IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN @@ -177,7 +178,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) MINWRK = MAX( 1, 2*N ) IF( .NOT.WANTVS ) THEN @@ -196,19 +197,18 @@ MAXWRK = MAX( MAXWRK, HSWORK, 1 ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -12 END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEES ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/zgeesx.f LAPACK/SRC/zgeesx.f --- LAPACK.orig/SRC/zgeesx.f Thu Nov 4 14:25:01 1999 +++ LAPACK/SRC/zgeesx.f Fri May 25 16:00:23 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Do WS calculations if LWORK = -1 (eca) * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT @@ -119,6 +120,10 @@ * this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. * For good performance, LWORK must generally be larger. * +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. +* * RWORK (workspace) DOUBLE PRECISION array, dimension (N) * * BWORK (workspace) LOGICAL array, dimension (N) @@ -144,6 +149,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. @@ -158,8 +165,8 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DLASCL, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD, - $ ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR + EXTERNAL DLABAD, DLASCL, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, + $ ZGEHRD, ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME @@ -211,7 +218,7 @@ * in the code.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) MINWRK = MAX( 1, 2*N ) IF( .NOT.WANTVS ) THEN @@ -229,18 +236,25 @@ HSWORK = MAX( K*( K+2 ), 2*N ) MAXWRK = MAX( MAXWRK, HSWORK, 1 ) END IF +* +* Estimate the workspace needed by ZTRSEN. +* + IF( WANTST ) THEN + MAXWRK = MAX( MAXWRK, ( N*N+1 ) / 2 ) + END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -15 END IF - IF( LWORK.LT.MINWRK ) THEN - INFO = -15 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEESX', -INFO ) RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/zgeev.f LAPACK/SRC/zgeev.f --- LAPACK.orig/SRC/zgeev.f Thu Nov 4 14:25:01 1999 +++ LAPACK/SRC/zgeev.f Fri May 25 16:00:53 2001 @@ -5,6 +5,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -85,10 +86,9 @@ * 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. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) * @@ -103,11 +103,13 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, SCALEA, WANTVL, WANTVR + LOGICAL SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, $ IWRK, K, MAXB, MAXWRK, MINWRK, NOUT @@ -119,8 +121,8 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, ZHSEQR, - $ ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR + EXTERNAL DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, + $ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME @@ -136,7 +138,6 @@ * 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 @@ -165,7 +166,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = MAX( 1, 2*N ) @@ -185,19 +186,18 @@ MAXWRK = MAX( MAXWRK, HSWORK, 2*N ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -12 END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEEV ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/zgeevx.f LAPACK/SRC/zgeevx.f --- LAPACK.orig/SRC/zgeevx.f Thu Nov 4 14:25:01 1999 +++ LAPACK/SRC/zgeevx.f Fri May 25 16:01:18 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE @@ -166,10 +167,9 @@ * LWORK >= N*N+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. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) * @@ -184,12 +184,14 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, - $ WNTSNN, WNTSNV + LOGICAL SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, WNTSNN, + $ WNTSNV CHARACTER JOB, SIDE INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXB, $ MAXWRK, MINWRK, NOUT @@ -201,9 +203,9 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DLASCL, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, - $ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZTRSNA, - $ ZUNGHR + EXTERNAL DLABAD, DLASCL, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, + $ ZGEHRD, ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, + $ ZTRSNA, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME @@ -219,7 +221,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) WANTVL = LSAME( JOBVL, 'V' ) WANTVR = LSAME( JOBVR, 'V' ) WNTSNN = LSAME( SENSE, 'N' ) @@ -260,7 +261,7 @@ * the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = MAX( 1, 2*N ) @@ -294,19 +295,18 @@ MAXWRK = MAX( MAXWRK, 2*N, 1 ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -20 END IF - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -20 - END IF +* +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEEVX', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/zgegs.f LAPACK/SRC/zgegs.f --- LAPACK.orig/SRC/zgegs.f Thu Nov 4 14:25:01 1999 +++ LAPACK/SRC/zgegs.f Fri May 25 16:02:04 2001 @@ -5,7 +5,7 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR @@ -23,83 +23,71 @@ * * This routine is deprecated and has been replaced by routine ZGGES. * -* ZGEGS computes for a pair of N-by-N complex nonsymmetric matrices A, -* B: the generalized eigenvalues (alpha, beta), the complex Schur -* form (A, B), and optionally left and/or right Schur vectors -* (VSL and VSR). -* -* (If only the generalized eigenvalues are needed, use the driver ZGEGV -* instead.) -* -* A generalized eigenvalue for a pair of matrices (A,B) is, roughly -* speaking, a scalar w or a ratio alpha/beta = w, such that A - w*B -* is singular. It is usually represented as the pair (alpha,beta), -* as there is a reasonable interpretation for beta=0, and even for -* both being zero. A good beginning reference is the book, "Matrix -* Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press) -* -* The (generalized) Schur form of a pair of matrices is the result of -* multiplying both matrices on the left by one unitary matrix and -* both on the right by another unitary matrix, these two unitary -* matrices being chosen so as to bring the pair of matrices into -* upper triangular form with the diagonal elements of B being -* non-negative real numbers (this is also called complex Schur form.) -* -* The left and right Schur vectors are the columns of VSL and VSR, -* respectively, where VSL and VSR are the unitary matrices -* which reduce A and B to Schur form: -* -* Schur form of (A,B) = ( (VSL)**H A (VSR), (VSL)**H B (VSR) ) +* ZGEGS computes the eigenvalues, Schur form, and, optionally, the +* left and or/right Schur vectors of a complex matrix pair (A,B). +* Given two square matrices A and B, the generalized Schur +* factorization has the form +* +* A = Q*S*Z**H, B = Q*T*Z**H +* +* where Q and Z are unitary matrices and S and T are upper triangular. +* The columns of Q are the left Schur vectors +* and the columns of Z are the right Schur vectors. +* +* If only the eigenvalues of (A,B) are needed, the driver routine +* ZGEGV should be used instead. See ZGEGV for a description of the +* eigenvalues of the generalized nonsymmetric eigenvalue problem +* (GNEP). * * Arguments * ========= * * JOBVSL (input) CHARACTER*1 * = 'N': do not compute the left Schur vectors; -* = 'V': compute the left Schur vectors. +* = 'V': compute the left Schur vectors (returned in VSL). * * JOBVSR (input) CHARACTER*1 * = 'N': do not compute the right Schur vectors; -* = 'V': compute the right Schur vectors. +* = 'V': compute the right Schur vectors (returned in VSR). * * N (input) INTEGER * The order of the matrices A, B, VSL, and VSR. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA, N) -* On entry, the first of the pair of matrices whose generalized -* eigenvalues and (optionally) Schur vectors are to be -* computed. -* On exit, the generalized Schur form of A. +* On entry, the matrix A. +* On exit, the upper triangular matrix S from the generalized +* Schur factorization. * * LDA (input) INTEGER * The leading dimension of A. LDA >= max(1,N). * * B (input/output) COMPLEX*16 array, dimension (LDB, N) -* On entry, the second of the pair of matrices whose -* generalized eigenvalues and (optionally) Schur vectors are -* to be computed. -* On exit, the generalized Schur form of B. +* On entry, the matrix B. +* On exit, the upper triangular matrix T from the generalized +* Schur factorization. * * LDB (input) INTEGER * The leading dimension of B. LDB >= max(1,N). * * ALPHA (output) COMPLEX*16 array, dimension (N) +* The complex scalars alpha that define the eigenvalues of +* GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur +* form of A. +* * BETA (output) COMPLEX*16 array, dimension (N) -* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the -* generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j), -* j=1,...,N are the diagonals of the complex Schur form (A,B) -* output by ZGEGS. The BETA(j) will be non-negative real. -* -* Note: the quotients ALPHA(j)/BETA(j) may easily over- or -* underflow, and BETA(j) may even be zero. Thus, the user -* should avoid naively computing the ratio alpha/beta. -* However, ALPHA will be always less than and usually -* comparable with norm(A) in magnitude, and BETA always less -* than and usually comparable with norm(B). +* The non-negative real scalars beta that define the +* eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element +* of the triangular factor T. +* +* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) +* represent the j-th eigenvalue of the matrix pair (A,B), in +* one of the forms lambda = alpha/beta or mu = beta/alpha. +* Since either lambda or mu may overflow, they should not, +* in general, be computed. +* * * VSL (output) COMPLEX*16 array, dimension (LDVSL,N) -* If JOBVSL = 'V', VSL will contain the left Schur vectors. -* (See "Purpose", above.) +* If JOBVSL = 'V', the matrix of left Schur vectors Q. * Not referenced if JOBVSL = 'N'. * * LDVSL (input) INTEGER @@ -107,8 +95,7 @@ * if JOBVSL = 'V', LDVSL >= N. * * VSR (output) COMPLEX*16 array, dimension (LDVSR,N) -* If JOBVSR = 'V', VSR will contain the right Schur vectors. -* (See "Purpose", above.) +* If JOBVSR = 'V', the matrix of right Schur vectors Z. * Not referenced if JOBVSR = 'N'. * * LDVSR (input) INTEGER diff -uNr LAPACK.orig/SRC/zgegv.f LAPACK/SRC/zgegv.f --- LAPACK.orig/SRC/zgegv.f Thu Nov 4 14:25:45 1999 +++ LAPACK/SRC/zgegv.f Fri May 25 16:02:27 2001 @@ -4,7 +4,7 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -22,22 +22,28 @@ * * This routine is deprecated and has been replaced by routine ZGGEV. * -* ZGEGV computes for a pair of N-by-N complex nonsymmetric matrices A -* and B, the generalized eigenvalues (alpha, beta), and optionally, -* the left and/or right generalized eigenvectors (VL and VR). -* -* A generalized eigenvalue for a pair of matrices (A,B) is, roughly -* speaking, a scalar w or a ratio alpha/beta = w, such that A - w*B -* is singular. It is usually represented as the pair (alpha,beta), -* as there is a reasonable interpretation for beta=0, and even for -* both being zero. A good beginning reference is the book, "Matrix -* Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press) -* -* A right generalized eigenvector corresponding to a generalized -* eigenvalue w for a pair of matrices (A,B) is a vector r such -* that (A - w B) r = 0 . A left generalized eigenvector is a vector -* l such that l**H * (A - w B) = 0, where l**H is the -* conjugate-transpose of l. +* ZGEGV computes the eigenvalues and, optionally, the left and/or right +* eigenvectors of a complex matrix pair (A,B). +* Given two square matrices A and B, +* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the +* eigenvalues lambda and corresponding (non-zero) eigenvectors x such +* that +* A*x = lambda*B*x. +* +* An alternate form is to find the eigenvalues mu and corresponding +* eigenvectors y such that +* mu*A*y = B*y. +* +* These two forms are equivalent with mu = 1/lambda and x = y if +* neither lambda nor mu is zero. In order to deal with the case that +* lambda or mu is zero or small, two values alpha and beta are returned +* for each eigenvalue, such that lambda = alpha/beta and +* mu = beta/alpha. +* +* The vectors x and y in the above equations are right eigenvectors of +* the matrix pair (A,B). Vectors u and v satisfying +* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B +* are left eigenvectors of (A,B). * * Note: this routine performs "full balancing" on A and B -- see * "Further Details", below. @@ -47,56 +53,61 @@ * * JOBVL (input) CHARACTER*1 * = 'N': do not compute the left generalized eigenvectors; -* = 'V': compute the left generalized eigenvectors. +* = 'V': compute the left generalized eigenvectors (returned +* in VL). * * JOBVR (input) CHARACTER*1 * = 'N': do not compute the right generalized eigenvectors; -* = 'V': compute the right generalized eigenvectors. +* = 'V': compute the right generalized eigenvectors (returned +* in VR). * * N (input) INTEGER * The order of the matrices A, B, VL, and VR. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA, N) -* On entry, the first of the pair of matrices whose -* generalized eigenvalues and (optionally) generalized -* eigenvectors are to be computed. -* On exit, the contents will have been destroyed. (For a -* description of the contents of A on exit, see "Further -* Details", below.) +* On entry, the matrix A. +* If JOBVL = 'V' or JOBVR = 'V', then on exit A +* contains the Schur form of A from the generalized Schur +* factorization of the pair (A,B) after balancing. If no +* eigenvectors were computed, then only the diagonal elements +* of the Schur form will be correct. See ZGGHRD and ZHGEQZ +* for details. * * LDA (input) INTEGER * The leading dimension of A. LDA >= max(1,N). * * B (input/output) COMPLEX*16 array, dimension (LDB, N) -* On entry, the second of the pair of matrices whose -* generalized eigenvalues and (optionally) generalized -* eigenvectors are to be computed. -* On exit, the contents will have been destroyed. (For a -* description of the contents of B on exit, see "Further -* Details", below.) +* On entry, the matrix B. +* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the +* upper triangular matrix obtained from B in the generalized +* Schur factorization of the pair (A,B) after balancing. +* If no eigenvectors were computed, then only the diagonal +* elements of B will be correct. See ZGGHRD and ZHGEQZ for +* details. * * LDB (input) INTEGER * The leading dimension of B. LDB >= max(1,N). * * ALPHA (output) COMPLEX*16 array, dimension (N) -* BETA (output) COMPLEX*16 array, dimension (N) -* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the -* generalized eigenvalues. +* The complex scalars alpha that define the eigenvalues of +* GNEP. * -* Note: the quotients ALPHA(j)/BETA(j) may easily over- or -* underflow, and BETA(j) may even be zero. Thus, the user -* should avoid naively computing the ratio alpha/beta. -* However, ALPHA will be always less than and usually -* comparable with norm(A) in magnitude, and BETA always less -* than and usually comparable with norm(B). +* BETA (output) COMPLEX*16 array, dimension (N) +* The complex scalars beta that define the eigenvalues of GNEP. +* +* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) +* represent the j-th eigenvalue of the matrix pair (A,B), in +* one of the forms lambda = alpha/beta or mu = beta/alpha. +* Since either lambda or mu may overflow, they should not, +* in general, be computed. * * VL (output) COMPLEX*16 array, dimension (LDVL,N) -* If JOBVL = 'V', the left generalized eigenvectors. (See -* "Purpose", above.) -* Each eigenvector will be scaled so the largest component -* will have abs(real part) + abs(imag. part) = 1, *except* -* that for eigenvalues with alpha=beta=0, a zero vector will -* be returned as the corresponding eigenvector. +* If JOBVL = 'V', the left eigenvectors u(j) are stored +* in the columns of VL, in the same order as their eigenvalues. +* Each eigenvector is scaled so that its largest component has +* abs(real part) + abs(imag. part) = 1, except for eigenvectors +* corresponding to an eigenvalue with alpha = beta = 0, which +* are set to zero. * Not referenced if JOBVL = 'N'. * * LDVL (input) INTEGER @@ -104,12 +115,12 @@ * if JOBVL = 'V', LDVL >= N. * * VR (output) COMPLEX*16 array, dimension (LDVR,N) -* If JOBVR = 'V', the right generalized eigenvectors. (See -* "Purpose", above.) -* Each eigenvector will be scaled so the largest component -* will have abs(real part) + abs(imag. part) = 1, *except* -* that for eigenvalues with alpha=beta=0, a zero vector will -* be returned as the corresponding eigenvector. +* If JOBVR = 'V', the right eigenvectors x(j) are stored +* in the columns of VR, in the same order as their eigenvalues. +* Each eigenvector is scaled so that its largest component has +* abs(real part) + abs(imag. part) = 1, except for eigenvectors +* corresponding to an eigenvalue with alpha = beta = 0, which +* are set to zero. * Not referenced if JOBVR = 'N'. * * LDVR (input) INTEGER @@ -123,8 +134,8 @@ * The dimension of the array WORK. LWORK >= max(1,2*N). * For good performance, LWORK must generally be larger. * To compute the optimal value of LWORK, call ILAENV to get -* blocksizes (for ZGEQRF, ZUNMQR, and CUNGQR.) Then compute: -* NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and CUNGQR; +* blocksizes (for ZGEQRF, ZUNMQR, and ZUNGQR.) Then compute: +* NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and ZUNGQR; * The optimal LWORK is MAX( 2*N, N*(NB+1) ). * * If LWORK = -1, then a workspace query is assumed; the routine diff -uNr LAPACK.orig/SRC/zgelsd.f LAPACK/SRC/zgelsd.f --- LAPACK.orig/SRC/zgelsd.f Thu Nov 4 14:26:26 1999 +++ LAPACK/SRC/zgelsd.f Fri May 25 16:03:34 2001 @@ -4,7 +4,8 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -62,9 +63,10 @@ * The number of right hand sides, i.e., the number of columns * of the matrices B and X. NRHS >= 0. * -* A (input) COMPLEX*16 array, dimension (LDA,N) +* A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N matrix A. -* On exit, A has been destroyed. +* On exit, the first min(m,n) rows of A are overwritten with +* its right singular vectors, stored rowwise. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). @@ -96,31 +98,24 @@ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER -* The dimension of the array WORK. LWORK must be at least 1. +* The dimension of the array WORK. LWORK >= 1. * The exact minimum amount of workspace needed depends on M, -* N and NRHS. As long as LWORK is at least -* 2 * N + N * NRHS -* if M is greater than or equal to N or -* 2 * M + M * NRHS -* if M is less than N, the code will execute correctly. +* N and NRHS. +* If M >= N, LWORK >= 2*N + N*NRHS. +* If M < N, LWORK >= 2*M + M*NRHS. * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* RWORK (workspace) DOUBLE PRECISION array, dimension at least -* 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + -* (SMLSIZ+1)**2 -* if M is greater than or equal to N or -* 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS + -* (SMLSIZ+1)**2 -* if M is less than N, the code will execute correctly. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (LRWORK) +* If M >= N, LRWORK >= 8*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS. +* If M < N, LRWORK >= 8*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS. * SMLSIZ is returned by ILAENV and is equal to the maximum * size of the subproblems at the bottom of the computation * tree (usually about 25), and -* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) +* NLVL = INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 * * IWORK (workspace) INTEGER array, dimension (LIWORK) * LIWORK >= 3 * MINMN * NLVL + 11 * MINMN, @@ -144,13 +139,14 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL LQUERY INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ, $ LDWORK, MAXMN, MAXWRK, MINMN, MINWRK, MM, $ MNTHR, NRWORK, NWORK, SMLSIZ @@ -177,7 +173,6 @@ MINMN = MIN( M, N ) MAXMN = MAX( M, N ) MNTHR = ILAENV( 6, 'ZGELSD', ' ', M, N, NRHS, -1 ) - LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN @@ -261,20 +256,18 @@ END IF MINWRK = MIN( MINWRK, MAXWRK ) WORK( 1 ) = DCMPLX( MAXWRK, 0 ) - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -12 END IF * +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELSD', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - GO TO 10 END IF -* -* Quick return if possible. -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( M.EQ.0 .OR. N.EQ.0 ) THEN RANK = 0 RETURN diff -uNr LAPACK.orig/SRC/zgelss.f LAPACK/SRC/zgelss.f --- LAPACK.orig/SRC/zgelss.f Thu Nov 4 14:25:02 1999 +++ LAPACK/SRC/zgelss.f Fri May 25 16:04:00 2001 @@ -4,7 +4,7 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -87,10 +87,9 @@ * LWORK >= 2*min(M,N) + max(M,N,NRHS) * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)) * @@ -164,7 +163,7 @@ * immediately following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 0 MM = M IF( M.GE.N .AND. M.GE.MNTHR ) THEN @@ -232,22 +231,20 @@ MAXWRK = MAX( MAXWRK, N*NRHS ) END IF END IF - MINWRK = MAX( MINWRK, 1 ) MAXWRK = MAX( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELSS', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF -* -* Quick return if possible -* IF( M.EQ.0 .OR. N.EQ.0 ) THEN RANK = 0 RETURN @@ -512,8 +509,8 @@ DO 40 I = 1, NRHS, CHUNK BL = MIN( NRHS-I+1, CHUNK ) CALL ZGEMM( 'C', 'N', M, BL, M, CONE, WORK( IL ), LDWORK, - $ B( 1, I ), LDB, CZERO, WORK( IWORK ), N ) - CALL ZLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ), + $ B( 1, I ), LDB, CZERO, WORK( IWORK ), M ) + CALL ZLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), $ LDB ) 40 CONTINUE ELSE diff -uNr LAPACK.orig/SRC/zgesdd.f LAPACK/SRC/zgesdd.f --- LAPACK.orig/SRC/zgesdd.f Thu Nov 11 20:33:19 1999 +++ LAPACK/SRC/zgesdd.f Fri May 25 16:08:08 2001 @@ -4,7 +4,8 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBZ @@ -119,12 +120,14 @@ * if JOBZ = 'S' or 'A', * LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N). * For good performance, LWORK should generally be larger. -* If LWORK < 0 but other input arguments are legal, WORK(1) -* returns the optimal LWORK. +* +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) DOUBLE PRECISION array, dimension (LRWORK) -* If JOBZ = 'N', LRWORK >= 7*min(M,N). -* Otherwise, LRWORK >= 5*min(M,N)*min(M,N) + 5*min(M,N) +* If JOBZ = 'N', LRWORK >= 5*min(M,N). +* Otherwise, LRWORK >= 5*min(M,N)*min(M,N) + 7*min(M,N) * * IWORK (workspace) INTEGER array, dimension (8*min(M,N)) * @@ -143,14 +146,16 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), - $ CONE = ( 1.0D0, 0.0D0 ) ) + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS + LOGICAL WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS INTEGER BLK, CHUNK, I, IE, IERR, IL, IR, IRU, IRVT, $ ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT, $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK, @@ -162,15 +167,15 @@ DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. - EXTERNAL DBDSDC, DLASCL, XERBLA, ZGEBRD, ZGELQF, ZGEMM, - $ ZGEQRF, ZLACP2, ZLACPY, ZLACRM, ZLARCM, ZLASCL, + EXTERNAL DBDSDC, DLASCL, XERBLA, ZGEBRD, ZGELQF, ZGEMM, + $ ZGEQRF, ZLACP2, ZLACPY, ZLACRM, ZLARCM, ZLASCL, $ ZLASET, ZUNGBR, ZUNGLQ, ZUNGQR, ZUNMBR * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE + EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, SQRT @@ -190,7 +195,6 @@ WNTQN = LSAME( JOBZ, 'N' ) MINWRK = 1 MAXWRK = 1 - LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN INFO = -1 @@ -221,19 +225,21 @@ IF( M.GE.N ) THEN * * There is no complex work space needed for bidiagonal SVD -* The real work space needed for bidiagonal SVD is BDSPAC, -* BDSPAC = 3*N*N + 4*N +* The real work space needed for bidiagonal SVD is BDSPAC +* for computing singular values and singular vectors; BDSPAN +* for computing singular values only. +* BDSPAC = 5*N*N + 7*N +* BDSPAN = MAX(7*N+4, 3*N+2+SMLSIZ*(SMLSIZ+8)) * IF( M.GE.MNTHR1 ) THEN IF( WNTQN ) THEN * * Path 1 (M much larger than N, JOBZ='N') * - WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, - $ -1 ) - WRKBL = MAX( WRKBL, 2*N+2*N* - $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) - MAXWRK = WRKBL + MAXWRK = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, 2*N+2*N* + $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) MINWRK = 3*N ELSE IF( WNTQO ) THEN * @@ -335,8 +341,11 @@ ELSE * * There is no complex work space needed for bidiagonal SVD -* The real work space needed for bidiagonal SVD is BDSPAC, -* BDSPAC = 3*M*M + 4*M +* The real work space needed for bidiagonal SVD is BDSPAC +* for computing singular values and singular vectors; BDSPAN +* for computing singular values only. +* BDSPAC = 5*M*M + 7*M +* BDSPAN = MAX(7*M+4, 3*M+2+SMLSIZ*(SMLSIZ+8)) * IF( N.GE.MNTHR1 ) THEN IF( WNTQN ) THEN @@ -447,24 +456,22 @@ END IF END IF MAXWRK = MAX( MAXWRK, MINWRK ) + END IF + IF( INFO.EQ.0 ) THEN WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -13 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGESDD', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE RETURN END IF * @@ -529,7 +536,7 @@ * * Perform bidiagonal SVD, compute singular values only * (CWorkspace: 0) -* (RWorkspace: need BDSPAC) +* (RWorkspace: need BDSPAN) * CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) @@ -844,7 +851,7 @@ * * Compute singular values only * (Cworkspace: 0) -* (Rworkspace: need BDSPAC) +* (Rworkspace: need BDSPAN) * CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) @@ -1040,7 +1047,7 @@ * * Compute singular values only * (Cworkspace: 0) -* (Rworkspace: need BDSPAC) +* (Rworkspace: need BDSPAN) * CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) @@ -1205,8 +1212,8 @@ 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) +* columns than rows, first reduce using the LQ decomposition (if +* sufficient workspace available) * IF( N.GE.MNTHR1 ) THEN * @@ -1245,7 +1252,7 @@ * * Perform bidiagonal SVD, compute singular values only * (CWorkspace: 0) -* (RWorkspace: need BDSPAC) +* (RWorkspace: need BDSPAN) * CALL DBDSDC( 'U', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) @@ -1567,7 +1574,7 @@ * * Compute singular values only * (Cworkspace: 0) -* (Rworkspace: need BDSPAC) +* (Rworkspace: need BDSPAN) * CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) @@ -1763,7 +1770,7 @@ * * Compute singular values only * (Cworkspace: 0) -* (Rworkspace: need BDSPAC) +* (Rworkspace: need BDSPAN) * CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO ) @@ -1934,9 +1941,15 @@ 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) diff -uNr LAPACK.orig/SRC/zgesvd.f LAPACK/SRC/zgesvd.f --- LAPACK.orig/SRC/zgesvd.f Thu Nov 4 14:25:03 1999 +++ LAPACK/SRC/zgesvd.f Fri May 25 16:08:34 2001 @@ -4,7 +4,8 @@ * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT @@ -114,12 +115,12 @@ * LWORK >= 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. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * -* RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)) +* 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). @@ -137,6 +138,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) @@ -144,8 +147,8 @@ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, - $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS + LOGICAL WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, WNTVA, + $ WNTVAS, WNTVN, WNTVO, WNTVS INTEGER BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL, $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, @@ -188,7 +191,7 @@ WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) MINWRK = 1 - LQUERY = ( LWORK.EQ.-1 ) + MAXWRK = 1 * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN INFO = -1 @@ -216,8 +219,7 @@ * real workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV.) * - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. - $ N.GT.0 ) THEN + IF( INFO.EQ.0 .AND. M.GT.0 .AND. N.GT.0 ) THEN IF( M.GE.N ) THEN * * Space needed for ZBDSQR is BDSPAC = 5*N @@ -543,24 +545,22 @@ MAXWRK = MAX( MINWRK, MAXWRK ) END IF END IF + END IF + IF( INFO.EQ.0 ) THEN WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -13 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGESVD', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE RETURN END IF * diff -uNr LAPACK.orig/SRC/zggbak.f LAPACK/SRC/zggbak.f --- LAPACK.orig/SRC/zggbak.f Thu Nov 4 14:25:03 1999 +++ LAPACK/SRC/zggbak.f Fri May 25 16:09:06 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* February 1, 2001 * * .. Scalar Arguments .. CHARACTER JOB, SIDE @@ -109,10 +109,15 @@ INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 - ELSE IF( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) THEN + ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN + INFO = -4 + ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) + $ THEN + INFO = -5 + ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN - INFO = -6 + INFO = -8 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF diff -uNr LAPACK.orig/SRC/zggbal.f LAPACK/SRC/zggbal.f --- LAPACK.orig/SRC/zggbal.f Thu Nov 4 14:25:45 1999 +++ LAPACK/SRC/zggbal.f Fri May 25 16:09:27 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* April 12, 2001 * * .. Scalar Arguments .. CHARACTER JOB @@ -150,7 +150,7 @@ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -5 + INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGBAL', -INFO ) @@ -197,8 +197,8 @@ IF( L.NE.1 ) $ GO TO 30 * - RSCALE( 1 ) = 1 - LSCALE( 1 ) = 1 + RSCALE( 1 ) = ONE + LSCALE( 1 ) = ONE GO TO 190 * 30 CONTINUE @@ -256,7 +256,7 @@ * Permute rows M and I * 160 CONTINUE - LSCALE( M ) = I + LSCALE( M ) = DBLE( I ) IF( I.EQ.M ) $ GO TO 170 CALL ZSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) @@ -265,7 +265,7 @@ * Permute columns M and J * 170 CONTINUE - RSCALE( M ) = J + RSCALE( M ) = DBLE( J ) IF( J.EQ.M ) $ GO TO 180 CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) @@ -437,7 +437,7 @@ DO 360 I = ILO, IHI IRAB = IZAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) - IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDA ) + IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) diff -uNr LAPACK.orig/SRC/zgges.f LAPACK/SRC/zgges.f --- LAPACK.orig/SRC/zgges.f Thu Nov 4 14:26:21 1999 +++ LAPACK/SRC/zgges.f Fri May 25 16:09:47 2001 @@ -6,6 +6,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SORT @@ -145,10 +146,9 @@ * 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. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) DOUBLE PRECISION array, dimension (8*N) * @@ -173,6 +173,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) COMPLEX*16 CZERO, CONE @@ -181,7 +183,7 @@ * .. * .. Local Scalars .. LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, - $ LQUERY, WANTST + $ WANTST INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, $ ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK, LWKMIN, $ LWKOPT @@ -193,8 +195,9 @@ DOUBLE PRECISION DIF( 2 ) * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, ZHGEQZ, - $ ZLACPY, ZLASCL, ZLASET, ZTGSEN, ZUNGQR, ZUNMQR + EXTERNAL DLABAD, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, + $ ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGSEN, ZUNGQR, + $ ZUNMQR * .. * .. External Functions .. LOGICAL LSAME @@ -236,7 +239,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN @@ -263,7 +265,7 @@ * following subroutine, as returned by ILAENV.) * LWKMIN = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN LWKMIN = MAX( 1, 2*N ) LWKOPT = N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) IF( ILVSL ) THEN @@ -271,21 +273,18 @@ $ -1 ) ) END IF WORK( 1 ) = LWKOPT + IF( LWORK.LT.LWKMIN .AND. LWORK.NE.LQUERV ) + $ INFO = -18 END IF * - IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) - $ INFO = -18 +* Quick return if possible * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGES ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* - WORK( 1 ) = LWKOPT + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/zggesx.f LAPACK/SRC/zggesx.f --- LAPACK.orig/SRC/zggesx.f Thu Nov 4 14:26:21 1999 +++ LAPACK/SRC/zggesx.f Fri May 25 16:10:05 2001 @@ -7,6 +7,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Do WS calculations if LWORK = -1 (eca) * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SENSE, SORT @@ -167,6 +168,10 @@ * If SENSE = 'E', 'V', or 'B', * LWORK >= MAX(2*N, 2*SDIM*(N-SDIM)). * +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. +* * RWORK (workspace) DOUBLE PRECISION array, dimension ( 8*N ) * Real workspace. * @@ -198,6 +203,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) COMPLEX*16 CZERO, CONE @@ -217,8 +224,9 @@ DOUBLE PRECISION DIF( 2 ) * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, ZHGEQZ, - $ ZLACPY, ZLASCL, ZLASET, ZTGSEN, ZUNGQR, ZUNMQR + EXTERNAL DLABAD, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, + $ ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGSEN, ZUNGQR, + $ ZUNMQR * .. * .. External Functions .. LOGICAL LSAME @@ -303,14 +311,22 @@ * following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + IF( INFO.EQ.0 ) THEN MINWRK = MAX( 1, 2*N ) MAXWRK = N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) IF( ILVSL ) THEN MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, $ -1 ) ) END IF +* +* Estimate the workspace needed by ZTGSEN. +* + IF( WANTST ) THEN + MAXWRK = MAX( MAXWRK, ( N*N+1 ) / 2 ) + END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -21 END IF IF( .NOT.WANTSN ) THEN LIWMIN = N + 2 @@ -318,21 +334,19 @@ LIWMIN = 1 END IF IWORK( 1 ) = LIWMIN -* - IF( INFO.EQ.0 .AND. LWORK.LT.MINWRK ) THEN - INFO = -21 - ELSE IF( INFO.EQ.0 .AND. IJOB.GE.1 ) THEN + IF( INFO.EQ.0 .AND. IJOB.GE.1 ) THEN IF( LIWORK.LT.LIWMIN ) $ INFO = -24 END IF * +* Quick returns +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGESX', -INFO ) RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) THEN SDIM = 0 RETURN diff -uNr LAPACK.orig/SRC/zggev.f LAPACK/SRC/zggev.f --- LAPACK.orig/SRC/zggev.f Thu Nov 4 14:26:21 1999 +++ LAPACK/SRC/zggev.f Fri May 25 16:10:25 2001 @@ -5,6 +5,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR @@ -113,10 +114,9 @@ * 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. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N) * @@ -133,6 +133,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) COMPLEX*16 CZERO, CONE @@ -140,7 +142,7 @@ $ CONE = ( 1.0D0, 0.0D0 ) ) * .. * .. Local Scalars .. - LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR CHARACTER CHTEMP INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, $ IN, IRIGHT, IROWS, IRWRK, ITAU, IWRK, JC, JR, @@ -153,8 +155,9 @@ LOGICAL LDUMMA( 1 ) * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, ZHGEQZ, - $ ZLACPY, ZLASCL, ZLASET, ZTGEVC, ZUNGQR, ZUNMQR + EXTERNAL DLABAD, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, + $ ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGEVC, ZUNGQR, + $ ZUNMQR * .. * .. External Functions .. LOGICAL LSAME @@ -201,7 +204,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN @@ -227,25 +229,22 @@ * computed assuming ILO = 1 and IHI = N, the worst case.) * LWKMIN = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN LWKOPT = N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) LWKMIN = MAX( 1, 2*N ) WORK( 1 ) = LWKOPT + IF( LWORK.LT.LWKMIN .AND. LWORK.NE.LQUERV ) + $ INFO = -15 END IF * - IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) - $ INFO = -15 +* Quick returns * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGEV ', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* - WORK( 1 ) = LWKOPT + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/zggevx.f LAPACK/SRC/zggevx.f --- LAPACK.orig/SRC/zggevx.f Thu Nov 4 14:26:21 1999 +++ LAPACK/SRC/zggevx.f Fri May 25 16:11:40 2001 @@ -7,6 +7,7 @@ * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 +* 8-15-00: Improve consistency of WS calculations (eca) * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE @@ -194,10 +195,9 @@ * If SENSE = 'N' or 'E', LWORK >= 2*N. * If SENSE = 'V' or 'B', LWORK >= 2*N*N+2*N. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) DOUBLE PRECISION array, dimension (6*N) * Real workspace. @@ -247,6 +247,8 @@ * ===================================================================== * * .. Parameters .. + INTEGER LQUERV + PARAMETER ( LQUERV = -1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) COMPLEX*16 CZERO, CONE @@ -254,8 +256,8 @@ $ CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, - $ WANTSB, WANTSE, WANTSN, WANTSV + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, WANTSB, + $ WANTSE, WANTSN, WANTSV CHARACTER CHTEMP INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS, $ ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK, MINWRK @@ -267,9 +269,9 @@ LOGICAL LDUMMA( 1 ) * .. * .. External Subroutines .. - EXTERNAL DLASCL, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, - $ ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGEVC, ZTGSNA, - $ ZUNGQR, ZUNMQR + EXTERNAL DLABAD, DLASCL, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, + $ ZGGHRD, ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGEVC, + $ ZTGSNA, ZUNGQR, ZUNMQR * .. * .. External Functions .. LOGICAL LSAME @@ -321,7 +323,6 @@ * Test the input arguments * INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, $ 'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) $ THEN @@ -354,7 +355,7 @@ * computed assuming ILO = 1 and IHI = N, the worst case.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) IF( WANTSE ) THEN MINWRK = MAX( 1, 2*N ) @@ -363,21 +364,18 @@ MAXWRK = MAX( MAXWRK, 2*N*N+2*N ) END IF WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV ) + $ INFO = -25 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -25 - END IF +* Quick returns * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGEVX', -INFO ) RETURN - ELSE IF( LQUERY ) THEN - RETURN END IF -* -* Quick return if possible -* + IF( LWORK.EQ.LQUERV ) + $ RETURN IF( N.EQ.0 ) $ RETURN * diff -uNr LAPACK.orig/SRC/zgghrd.f LAPACK/SRC/zgghrd.f --- LAPACK.orig/SRC/zgghrd.f Thu Nov 4 14:25:45 1999 +++ LAPACK/SRC/zgghrd.f Fri May 25 16:11:59 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ @@ -20,16 +20,29 @@ * * ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper * Hessenberg form using unitary transformations, where A is a -* general matrix and B is upper triangular: Q' * A * Z = H and -* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, -* and Q and Z are unitary, and ' means conjugate transpose. +* general matrix and B is upper triangular. The form of the +* generalized eigenvalue problem is +* A*x = lambda*B*x, +* and B is typically made upper triangular by computing its QR +* factorization and moving the unitary matrix Q to the left side +* of the equation. +* +* This subroutine simultaneously reduces A to a Hessenberg matrix H: +* Q**H*A*Z = H +* and transforms B to another upper triangular matrix T: +* Q**H*B*Z = T +* in order to reduce the problem to its standard form +* H*y = lambda*T*y +* where y = Z**H*x. * * The unitary matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be * postmultiplied into input matrices Q1 and Z1, so that -* -* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' -* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' +* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H +* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H +* If Q1 is the unitary matrix from the QR factorization of B in the +* original equation A*x = lambda*B*x, then ZGGHRD reduces the original +* problem to generalized Hessenberg form. * * Arguments * ========= @@ -53,10 +66,11 @@ * * 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 ZGGBAL; otherwise they should be set -* to 1 and N respectively. +* ILO and IHI mark the rows and columns of A which are to be +* reduced. 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 ZGGBAL; otherwise they +* should be set to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) COMPLEX*16 array, dimension (LDA, N) @@ -70,33 +84,28 @@ * * B (input/output) COMPLEX*16 array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. -* On exit, the upper triangular matrix T = Q' B Z. The +* On exit, the upper triangular matrix T = Q**H B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) COMPLEX*16 array, dimension (LDQ, N) -* If COMPQ='N': Q is not referenced. -* If COMPQ='I': on entry, Q need not be set, and on exit it -* contains the unitary matrix Q, where Q' -* is the product of the Givens transformations -* which are applied to A and B on the left. -* If COMPQ='V': on entry, Q must contain a unitary matrix -* Q1, and on exit this is overwritten by Q1*Q. +* On entry, if COMPQ = 'V', the unitary matrix Q1, typically +* from the QR factorization of B. +* On exit, if COMPQ='I', the unitary matrix Q, and if +* COMPQ = 'V', the product Q1*Q. +* Not referenced if COMPQ='N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * 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 it -* contains the unitary matrix Z, which is -* the product of the Givens transformations -* which are applied to A and B on the right. -* If COMPZ='V': on entry, Z must contain a unitary matrix -* Z1, and on exit this is overwritten by Z1*Z. +* On entry, if COMPZ = 'V', the unitary matrix Z1. +* On exit, if COMPZ='I', the unitary matrix Z, and if +* COMPZ = 'V', the product Z1*Z. +* Not referenced if COMPZ='N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. diff -uNr LAPACK.orig/SRC/zhbgst.f LAPACK/SRC/zhbgst.f --- LAPACK.orig/SRC/zhbgst.f Thu Nov 4 14:23:32 1999 +++ LAPACK/SRC/zhbgst.f Fri May 25 16:13:00 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* January 9, 2001 * * .. Scalar Arguments .. CHARACTER UPLO, VECT @@ -131,7 +131,7 @@ INFO = -3 ELSE IF( KA.LT.0 ) THEN INFO = -4 - ELSE IF( KB.LT.0 ) THEN + ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN INFO = -5 ELSE IF( LDAB.LT.KA+1 ) THEN INFO = -7 diff -uNr LAPACK.orig/SRC/zhgeqz.f LAPACK/SRC/zhgeqz.f --- LAPACK.orig/SRC/zhgeqz.f Thu Nov 4 14:25:05 1999 +++ LAPACK/SRC/zhgeqz.f Fri May 25 16:12:21 2001 @@ -1,43 +1,64 @@ - SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, + SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, $ RWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 3, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ) - COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), - $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) + COMPLEX*16 ALPHA( * ), BETA( * ), H( LDH, * ), + $ Q( LDQ, * ), T( LDT, * ), WORK( * ), + $ Z( LDZ, * ) * .. * * Purpose * ======= * -* ZHGEQZ implements a single-shift version of the QZ -* method for finding the generalized eigenvalues w(i)=ALPHA(i)/BETA(i) -* of the equation -* -* det( A - w(i) B ) = 0 -* -* If JOB='S', then the pair (A,B) is simultaneously -* reduced to Schur form (i.e., A and B are both upper triangular) by -* applying one unitary tranformation (usually called Q) on the left and -* another (usually called Z) on the right. The diagonal elements of -* A are then ALPHA(1),...,ALPHA(N), and of B are BETA(1),...,BETA(N). -* -* If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the unitary -* transformations used to reduce (A,B) are accumulated into the arrays -* Q and Z s.t.: -* -* Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* -* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* +* ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T), +* where H is an upper Hessenberg matrix and T is upper triangular, +* using the single-shift QZ method. +* Matrix pairs of this type are produced by the reduction to +* generalized upper Hessenberg form of a complex matrix pair (A,B): +* +* A = Q1*H*Z1**H, B = Q1*T*Z1**H, +* +* as computed by ZGGHRD. +* +* If JOB='S', then the Hessenberg-triangular pair (H,T) is +* also reduced to generalized Schur form, +* +* H = Q*S*Z**H, T = Q*P*Z**H, +* +* where Q and Z are unitary matrices and S and P are upper triangular. +* +* Optionally, the unitary matrix Q from the generalized Schur +* factorization may be postmultiplied into an input matrix Q1, and the +* unitary matrix Z may be postmultiplied into an input matrix Z1. +* If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced +* the matrix pair (A,B) to generalized Hessenberg form, then the output +* matrices Q1*Q and Z1*Z are the unitary factors from the generalized +* Schur factorization of (A,B): +* +* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. +* +* To avoid overflow, eigenvalues of the matrix pair (H,T) +* (equivalently, of (A,B)) are computed as a pair of complex values +* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an +* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) +* A*x = lambda*B*x +* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the +* alternate form of the GNEP +* mu*A*y = B*y. +* The values of alpha and beta for the i-th eigenvalue can be read +* directly from the generalized Schur form: alpha = S(i,i), +* beta = P(i,i). * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), @@ -47,83 +68,88 @@ * ========= * * JOB (input) CHARACTER*1 -* = 'E': compute only ALPHA and BETA. A and B will not -* necessarily be put into generalized Schur form. -* = 'S': put A and B into generalized Schur form, as well -* as computing ALPHA and BETA. +* = 'E': Compute eigenvalues only; +* = 'S': Computer eigenvalues and the Schur form. * * COMPQ (input) CHARACTER*1 -* = 'N': do not modify Q. -* = 'V': multiply the array Q on the right by the conjugate -* transpose of the unitary tranformation that is -* applied to the left side of A and B to reduce them -* to Schur form. -* = 'I': like COMPQ='V', except that Q will be initialized to -* the identity first. +* = 'N': Left Schur vectors (Q) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Q +* of left Schur vectors of (H,T) is returned; +* = 'V': Q must contain a unitary matrix Q1 on entry and +* the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 -* = 'N': do not modify Z. -* = 'V': multiply the array Z on the right by the unitary -* tranformation that is applied to the right side of -* A and B to reduce them to Schur form. -* = 'I': like COMPZ='V', except that Z will be initialized to -* the identity first. +* = 'N': Right Schur vectors (Z) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Z +* of right Schur vectors of (H,T) is returned; +* = 'V': Z must contain a unitary matrix Z1 on entry and +* the product Z1*Z is returned. * * N (input) INTEGER -* The order of the matrices A, B, Q, and Z. N >= 0. +* The order of the matrices H, T, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA, N) -* On entry, the N-by-N upper Hessenberg matrix A. Elements -* below the subdiagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to upper triangular form. -* If JOB='E', then on exit A will have been destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max( 1, N ). -* -* B (input/output) COMPLEX*16 array, dimension (LDB, N) -* On entry, the N-by-N upper triangular matrix B. Elements -* below the diagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to upper triangular form. -* If JOB='E', then on exit B will have been destroyed. +* ILO and IHI mark the rows and columns of H which are in +* Hessenberg form. It is assumed that A is already upper +* triangular in rows and columns 1:ILO-1 and IHI+1:N. +* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. +* +* H (input/output) COMPLEX*16 array, dimension (LDH, N) +* On entry, the N-by-N upper Hessenberg matrix H. +* On exit, if JOB = 'S', H contains the upper triangular +* matrix S from the generalized Schur factorization. +* If JOB = 'E', the diagonal of H matches that of S, but +* the rest of H is unspecified. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH >= max( 1, N ). +* +* T (input/output) COMPLEX*16 array, dimension (LDT, N) +* On entry, the N-by-N upper triangular matrix T. +* On exit, if JOB = 'S', T contains the upper triangular +* matrix P from the generalized Schur factorization. +* If JOB = 'E', the diagonal of T matches that of P, but +* the rest of T is unspecified. * -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max( 1, N ). +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max( 1, N ). * * ALPHA (output) COMPLEX*16 array, dimension (N) -* The diagonal elements of A when the pair (A,B) has been -* reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N -* are the generalized eigenvalues. +* The complex scalars alpha that define the eigenvalues of +* GNEP. ALPHA(i) = S(i,i) in the generalized Schur +* factorization. * * BETA (output) COMPLEX*16 array, dimension (N) -* The diagonal elements of B when the pair (A,B) has been -* reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N -* are the generalized eigenvalues. A and B are normalized -* so that BETA(1),...,BETA(N) are non-negative real numbers. +* The real non-negative scalars beta that define the +* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized +* Schur factorization. +* +* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) +* represent the j-th eigenvalue of the matrix pair (A,B), in +* one of the forms lambda = alpha/beta or mu = beta/alpha. +* Since either lambda or mu may overflow, they should not, +* in general, be computed. * * Q (input/output) COMPLEX*16 array, dimension (LDQ, N) -* If COMPQ='N', then Q will not be referenced. -* If COMPQ='V' or 'I', then the conjugate transpose of the -* unitary transformations which are applied to A and B on -* the left will be applied to the array Q on the right. +* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the +* reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the unitary matrix of left Schur +* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of +* left Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) COMPLEX*16 array, dimension (LDZ, N) -* If COMPZ='N', then Z will not be referenced. -* If COMPZ='V' or 'I', then the unitary transformations which -* are applied to A and B on the right will be applied to the -* array Z on the right. +* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the +* reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the unitary matrix of right Schur +* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of +* right Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. @@ -145,13 +171,12 @@ * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value -* = 1,...,N: the QZ iteration did not converge. (A,B) is not +* = 1,...,N: the QZ iteration did not converge. (H,T) is not * in Schur form, but ALPHA(i) and BETA(i), * i=INFO+1,...,N should be correct. -* = N+1,...,2*N: the shift calculation failed. (A,B) is not +* = N+1,...,2*N: the shift calculation failed. (H,T) is not * in Schur form, but ALPHA(i) and BETA(i), * i=INFO-N+1,...,N should be correct. -* > 2*N: various "impossible" errors. * * Further Details * =============== @@ -178,7 +203,7 @@ DOUBLE PRECISION ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL, $ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP COMPLEX*16 ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2, - $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T, + $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1, $ U12, X * .. * .. External Functions .. @@ -256,9 +281,9 @@ INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 - ELSE IF( LDA.LT.N ) THEN + ELSE IF( LDH.LT.N ) THEN INFO = -8 - ELSE IF( LDB.LT.N ) THEN + ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -14 @@ -294,8 +319,8 @@ IN = IHI + 1 - ILO SAFMIN = DLAMCH( 'S' ) ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) - ANORM = ZLANHS( 'F', IN, A( ILO, ILO ), LDA, RWORK ) - BNORM = ZLANHS( 'F', IN, B( ILO, ILO ), LDB, RWORK ) + ANORM = ZLANHS( 'F', IN, H( ILO, ILO ), LDH, RWORK ) + BNORM = ZLANHS( 'F', IN, T( ILO, ILO ), LDT, RWORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) @@ -305,23 +330,23 @@ * Set Eigenvalues IHI+1:N * DO 10 J = IHI + 1, N - ABSB = ABS( B( J, J ) ) + ABSB = ABS( T( J, J ) ) IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = DCONJG( B( J, J ) / ABSB ) - B( J, J ) = ABSB + SIGNBC = DCONJG( T( J, J ) / ABSB ) + T( J, J ) = ABSB IF( ILSCHR ) THEN - CALL ZSCAL( J-1, SIGNBC, B( 1, J ), 1 ) - CALL ZSCAL( J, SIGNBC, A( 1, J ), 1 ) + CALL ZSCAL( J-1, SIGNBC, T( 1, J ), 1 ) + CALL ZSCAL( J, SIGNBC, H( 1, J ), 1 ) ELSE - A( J, J ) = A( J, J )*SIGNBC + H( J, J ) = H( J, J )*SIGNBC END IF IF( ILZ ) $ CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 ) ELSE - B( J, J ) = CZERO + T( J, J ) = CZERO END IF - ALPHA( J ) = A( J, J ) - BETA( J ) = B( J, J ) + ALPHA( J ) = H( J, J ) + BETA( J ) = T( J, J ) 10 CONTINUE * * If IHI < ILO, skip QZ steps @@ -366,22 +391,22 @@ * Split the matrix if possible. * * Two tests: -* 1: A(j,j-1)=0 or j=ILO -* 2: B(j,j)=0 +* 1: H(j,j-1)=0 or j=ILO +* 2: T(j,j)=0 * * Special case: j=ILAST * IF( ILAST.EQ.ILO ) THEN GO TO 60 ELSE - IF( ABS1( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN - A( ILAST, ILAST-1 ) = CZERO + IF( ABS1( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = CZERO GO TO 60 END IF END IF * - IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN - B( ILAST, ILAST ) = CZERO + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = CZERO GO TO 50 END IF * @@ -389,30 +414,30 @@ * DO 40 J = ILAST - 1, ILO, -1 * -* Test 1: for A(j,j-1)=0 or j=ILO +* Test 1: for H(j,j-1)=0 or j=ILO * IF( J.EQ.ILO ) THEN ILAZRO = .TRUE. ELSE - IF( ABS1( A( J, J-1 ) ).LE.ATOL ) THEN - A( J, J-1 ) = CZERO + IF( ABS1( H( J, J-1 ) ).LE.ATOL ) THEN + H( J, J-1 ) = CZERO ILAZRO = .TRUE. ELSE ILAZRO = .FALSE. END IF END IF * -* Test 2: for B(j,j)=0 +* Test 2: for T(j,j)=0 * - IF( ABS( B( J, J ) ).LT.BTOL ) THEN - B( J, J ) = CZERO + IF( ABS( T( J, J ) ).LT.BTOL ) THEN + T( J, J ) = CZERO * * Test 1a: Check for 2 consecutive small subdiagonals in A * ILAZR2 = .FALSE. IF( .NOT.ILAZRO ) THEN - IF( ABS1( A( J, J-1 ) )*( ASCALE*ABS1( A( J+1, - $ J ) ) ).LE.ABS1( A( J, J ) )*( ASCALE*ATOL ) ) + IF( ABS1( H( J, J-1 ) )*( ASCALE*ABS1( H( J+1, + $ J ) ) ).LE.ABS1( H( J, J ) )*( ASCALE*ATOL ) ) $ ILAZR2 = .TRUE. END IF * @@ -424,21 +449,21 @@ * IF( ILAZRO .OR. ILAZR2 ) THEN DO 20 JCH = J, ILAST - 1 - CTEMP = A( JCH, JCH ) - CALL ZLARTG( CTEMP, A( JCH+1, JCH ), C, S, - $ A( JCH, JCH ) ) - A( JCH+1, JCH ) = CZERO - CALL ZROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA, - $ A( JCH+1, JCH+1 ), LDA, C, S ) - CALL ZROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB, - $ B( JCH+1, JCH+1 ), LDB, C, S ) + CTEMP = H( JCH, JCH ) + CALL ZLARTG( CTEMP, H( JCH+1, JCH ), C, S, + $ H( JCH, JCH ) ) + H( JCH+1, JCH ) = CZERO + CALL ZROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH, + $ H( JCH+1, JCH+1 ), LDH, C, S ) + CALL ZROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT, + $ T( JCH+1, JCH+1 ), LDT, C, S ) IF( ILQ ) $ CALL ZROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, DCONJG( S ) ) IF( ILAZR2 ) - $ A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C + $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C ILAZR2 = .FALSE. - IF( ABS1( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN + IF( ABS1( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN IF( JCH+1.GE.ILAST ) THEN GO TO 60 ELSE @@ -446,35 +471,35 @@ GO TO 70 END IF END IF - B( JCH+1, JCH+1 ) = CZERO + T( JCH+1, JCH+1 ) = CZERO 20 CONTINUE GO TO 50 ELSE * -* Only test 2 passed -- chase the zero to B(ILAST,ILAST) -* Then process as in the case B(ILAST,ILAST)=0 +* Only test 2 passed -- chase the zero to T(ILAST,ILAST) +* Then process as in the case T(ILAST,ILAST)=0 * DO 30 JCH = J, ILAST - 1 - CTEMP = B( JCH, JCH+1 ) - CALL ZLARTG( CTEMP, B( JCH+1, JCH+1 ), C, S, - $ B( JCH, JCH+1 ) ) - B( JCH+1, JCH+1 ) = CZERO + CTEMP = T( JCH, JCH+1 ) + CALL ZLARTG( CTEMP, T( JCH+1, JCH+1 ), C, S, + $ T( JCH, JCH+1 ) ) + T( JCH+1, JCH+1 ) = CZERO IF( JCH.LT.ILASTM-1 ) - $ CALL ZROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB, - $ B( JCH+1, JCH+2 ), LDB, C, S ) - CALL ZROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA, - $ A( JCH+1, JCH-1 ), LDA, C, S ) + $ CALL ZROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT, + $ T( JCH+1, JCH+2 ), LDT, C, S ) + CALL ZROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH, + $ H( JCH+1, JCH-1 ), LDH, C, S ) IF( ILQ ) $ CALL ZROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, DCONJG( S ) ) - CTEMP = A( JCH+1, JCH ) - CALL ZLARTG( CTEMP, A( JCH+1, JCH-1 ), C, S, - $ A( JCH+1, JCH ) ) - A( JCH+1, JCH-1 ) = CZERO - CALL ZROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1, - $ A( IFRSTM, JCH-1 ), 1, C, S ) - CALL ZROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1, - $ B( IFRSTM, JCH-1 ), 1, C, S ) + CTEMP = H( JCH+1, JCH ) + CALL ZLARTG( CTEMP, H( JCH+1, JCH-1 ), C, S, + $ H( JCH+1, JCH ) ) + H( JCH+1, JCH-1 ) = CZERO + CALL ZROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1, + $ H( IFRSTM, JCH-1 ), 1, C, S ) + CALL ZROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1, + $ T( IFRSTM, JCH-1 ), 1, C, S ) IF( ILZ ) $ CALL ZROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, $ C, S ) @@ -498,42 +523,42 @@ INFO = 2*N + 1 GO TO 210 * -* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a +* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a * 1x1 block. * 50 CONTINUE - CTEMP = A( ILAST, ILAST ) - CALL ZLARTG( CTEMP, A( ILAST, ILAST-1 ), C, S, - $ A( ILAST, ILAST ) ) - A( ILAST, ILAST-1 ) = CZERO - CALL ZROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1, - $ A( IFRSTM, ILAST-1 ), 1, C, S ) - CALL ZROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1, - $ B( IFRSTM, ILAST-1 ), 1, C, S ) + CTEMP = H( ILAST, ILAST ) + CALL ZLARTG( CTEMP, H( ILAST, ILAST-1 ), C, S, + $ H( ILAST, ILAST ) ) + H( ILAST, ILAST-1 ) = CZERO + CALL ZROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1, + $ H( IFRSTM, ILAST-1 ), 1, C, S ) + CALL ZROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1, + $ T( IFRSTM, ILAST-1 ), 1, C, S ) IF( ILZ ) $ CALL ZROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S ) * -* A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA +* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA * 60 CONTINUE - ABSB = ABS( B( ILAST, ILAST ) ) + ABSB = ABS( T( ILAST, ILAST ) ) IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = DCONJG( B( ILAST, ILAST ) / ABSB ) - B( ILAST, ILAST ) = ABSB + SIGNBC = DCONJG( T( ILAST, ILAST ) / ABSB ) + T( ILAST, ILAST ) = ABSB IF( ILSCHR ) THEN - CALL ZSCAL( ILAST-IFRSTM, SIGNBC, B( IFRSTM, ILAST ), 1 ) - CALL ZSCAL( ILAST+1-IFRSTM, SIGNBC, A( IFRSTM, ILAST ), + CALL ZSCAL( ILAST-IFRSTM, SIGNBC, T( IFRSTM, ILAST ), 1 ) + CALL ZSCAL( ILAST+1-IFRSTM, SIGNBC, H( IFRSTM, ILAST ), $ 1 ) ELSE - A( ILAST, ILAST ) = A( ILAST, ILAST )*SIGNBC + H( ILAST, ILAST ) = H( ILAST, ILAST )*SIGNBC END IF IF( ILZ ) $ CALL ZSCAL( N, SIGNBC, Z( 1, ILAST ), 1 ) ELSE - B( ILAST, ILAST ) = CZERO + T( ILAST, ILAST ) = CZERO END IF - ALPHA( ILAST ) = A( ILAST, ILAST ) - BETA( ILAST ) = B( ILAST, ILAST ) + ALPHA( ILAST ) = H( ILAST, ILAST ) + BETA( ILAST ) = T( ILAST, ILAST ) * * Go to next block -- exit if finished. * @@ -566,7 +591,7 @@ * Compute the Shift. * * At this point, IFIRST < ILAST, and the diagonal elements of -* B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in +* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in * magnitude) * IF( ( IITER / 10 )*10.NE.IITER ) THEN @@ -578,33 +603,33 @@ * We factor B as U*D, where U has unit diagonals, and * compute (A*inv(D))*inv(U). * - U12 = ( BSCALE*B( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD22 = ( ASCALE*A( ILAST, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) + U12 = ( BSCALE*T( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD22 = ( ASCALE*H( ILAST, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) ABI22 = AD22 - U12*AD21 * - T = HALF*( AD11+ABI22 ) - RTDISC = SQRT( T**2+AD12*AD21-AD11*AD22 ) - TEMP = DBLE( T-ABI22 )*DBLE( RTDISC ) + - $ DIMAG( T-ABI22 )*DIMAG( RTDISC ) + T1 = HALF*( AD11+ABI22 ) + RTDISC = SQRT( T1**2+AD12*AD21-AD11*AD22 ) + TEMP = DBLE( T1-ABI22 )*DBLE( RTDISC ) + + $ DIMAG( T1-ABI22 )*DIMAG( RTDISC ) IF( TEMP.LE.ZERO ) THEN - SHIFT = T + RTDISC + SHIFT = T1 + RTDISC ELSE - SHIFT = T - RTDISC + SHIFT = T1 - RTDISC END IF ELSE * * Exceptional shift. Chosen for no particularly good reason. * - ESHIFT = ESHIFT + DCONJG( ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) ) + ESHIFT = ESHIFT + DCONJG( ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) ) SHIFT = ESHIFT END IF * @@ -612,46 +637,46 @@ * DO 80 J = ILAST - 1, IFIRST + 1, -1 ISTART = J - CTEMP = ASCALE*A( J, J ) - SHIFT*( BSCALE*B( J, J ) ) + CTEMP = ASCALE*H( J, J ) - SHIFT*( BSCALE*T( J, J ) ) TEMP = ABS1( CTEMP ) - TEMP2 = ASCALE*ABS1( A( J+1, J ) ) + TEMP2 = ASCALE*ABS1( H( J+1, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( ABS1( A( J, J-1 ) )*TEMP2.LE.TEMP*ATOL ) + IF( ABS1( H( J, J-1 ) )*TEMP2.LE.TEMP*ATOL ) $ GO TO 90 80 CONTINUE * ISTART = IFIRST - CTEMP = ASCALE*A( IFIRST, IFIRST ) - - $ SHIFT*( BSCALE*B( IFIRST, IFIRST ) ) + CTEMP = ASCALE*H( IFIRST, IFIRST ) - + $ SHIFT*( BSCALE*T( IFIRST, IFIRST ) ) 90 CONTINUE * * Do an implicit-shift QZ sweep. * * Initial Q * - CTEMP2 = ASCALE*A( ISTART+1, ISTART ) + CTEMP2 = ASCALE*H( ISTART+1, ISTART ) CALL ZLARTG( CTEMP, CTEMP2, C, S, CTEMP3 ) * * Sweep * DO 150 J = ISTART, ILAST - 1 IF( J.GT.ISTART ) THEN - CTEMP = A( J, J-1 ) - CALL ZLARTG( CTEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = CZERO + CTEMP = H( J, J-1 ) + CALL ZLARTG( CTEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = CZERO END IF * DO 100 JC = J, ILASTM - CTEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -DCONJG( S )*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = CTEMP - CTEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -DCONJG( S )*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = CTEMP2 + CTEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -DCONJG( S )*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = CTEMP + CTEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -DCONJG( S )*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = CTEMP2 100 CONTINUE IF( ILQ ) THEN DO 110 JR = 1, N @@ -661,19 +686,19 @@ 110 CONTINUE END IF * - CTEMP = B( J+1, J+1 ) - CALL ZLARTG( CTEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = CZERO + CTEMP = T( J+1, J+1 ) + CALL ZLARTG( CTEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = CZERO * DO 120 JR = IFRSTM, MIN( J+2, ILAST ) - CTEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -DCONJG( S )*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = CTEMP + CTEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -DCONJG( S )*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = CTEMP 120 CONTINUE DO 130 JR = IFRSTM, J - CTEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -DCONJG( S )*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = CTEMP + CTEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -DCONJG( S )*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = CTEMP 130 CONTINUE IF( ILZ ) THEN DO 140 JR = 1, N @@ -701,23 +726,23 @@ * Set Eigenvalues 1:ILO-1 * DO 200 J = 1, ILO - 1 - ABSB = ABS( B( J, J ) ) + ABSB = ABS( T( J, J ) ) IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = DCONJG( B( J, J ) / ABSB ) - B( J, J ) = ABSB + SIGNBC = DCONJG( T( J, J ) / ABSB ) + T( J, J ) = ABSB IF( ILSCHR ) THEN - CALL ZSCAL( J-1, SIGNBC, B( 1, J ), 1 ) - CALL ZSCAL( J, SIGNBC, A( 1, J ), 1 ) + CALL ZSCAL( J-1, SIGNBC, T( 1, J ), 1 ) + CALL ZSCAL( J, SIGNBC, H( 1, J ), 1 ) ELSE - A( J, J ) = A( J, J )*SIGNBC + H( J, J ) = H( J, J )*SIGNBC END IF IF( ILZ ) $ CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 ) ELSE - B( J, J ) = CZERO + T( J, J ) = CZERO END IF - ALPHA( J ) = A( J, J ) - BETA( J ) = B( J, J ) + ALPHA( J ) = H( J, J ) + BETA( J ) = T( J, J ) 200 CONTINUE * * Normal Termination diff -uNr LAPACK.orig/SRC/zlasr.f LAPACK/SRC/zlasr.f --- LAPACK.orig/SRC/zlasr.f Thu Nov 4 14:25:06 1999 +++ LAPACK/SRC/zlasr.f Fri May 25 16:12:41 2001 @@ -3,7 +3,7 @@ * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 +* May 3, 2001 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE @@ -17,42 +17,77 @@ * Purpose * ======= * -* ZLASR performs the transformation +* ZLASR applies a sequence of real plane rotations to a complex matrix +* A, from either the left or the right. * -* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) +* When SIDE = 'L', the transformation takes the form * -* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) +* A := P*A * -* where A is an m by n complex matrix and P is an orthogonal matrix, -* consisting of a sequence of plane rotations determined by the -* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' -* and z = n when SIDE = 'R' or 'r' ): +* and when SIDE = 'R', the transformation takes the form * -* When DIRECT = 'F' or 'f' ( Forward sequence ) then -* -* P = P( z - 1 )*...*P( 2 )*P( 1 ), -* -* and when DIRECT = 'B' or 'b' ( Backward sequence ) then -* -* P = P( 1 )*P( 2 )*...*P( z - 1 ), -* -* where P( k ) is a plane rotation matrix for the following planes: -* -* when PIVOT = 'V' or 'v' ( Variable pivot ), -* the plane ( k, k + 1 ) -* -* when PIVOT = 'T' or 't' ( Top pivot ), -* the plane ( 1, k + 1 ) -* -* when PIVOT = 'B' or 'b' ( Bottom pivot ), -* the plane ( k, z ) -* -* c( k ) and s( k ) must contain the cosine and sine that define the -* matrix P( k ). The two by two plane rotation part of the matrix -* P( k ), R( k ), is assumed to be of the form -* -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) +* 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 * ========= @@ -61,13 +96,13 @@ * 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' +* = 'R': Right, compute A:= A*P**T * * 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 ) +* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) +* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation @@ -84,18 +119,22 @@ * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * -* C, S (input) DOUBLE PRECISION arrays, dimension +* 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' -* c(k) and s(k) contain the cosine and sine that define the -* matrix P(k). The two by two plane rotation part of the -* matrix P(k), R(k), is assumed to be of the form -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) +* 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' if SIDE = 'L'. +* 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). diff -uNr LAPACK.orig/SRC/ztgevc.f LAPACK/SRC/ztgevc.f --- LAPACK.orig/SRC/ztgevc.f Thu Nov 4 14:26:09 1999 +++ LAPACK/SRC/ztgevc.f Fri May 25 16:13:41 2001 @@ -1,19 +1,19 @@ - SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, + SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 4, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE - INTEGER INFO, LDA, LDB, LDVL, LDVR, M, MM, N + INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) DOUBLE PRECISION RWORK( * ) - COMPLEX*16 A( LDA, * ), B( LDB, * ), VL( LDVL, * ), + COMPLEX*16 P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * @@ -21,28 +21,30 @@ * Purpose * ======= * -* ZTGEVC computes some or all of the right and/or left generalized -* eigenvectors of a pair of complex upper triangular matrices (A,B). -* -* The right generalized eigenvector x and the left generalized -* eigenvector y of (A,B) corresponding to a generalized eigenvalue -* w are defined by: -* -* (A - wB) * x = 0 and y**H * (A - wB) = 0 -* +* ZTGEVC computes some or all of the right and/or left eigenvectors of +* a pair of complex matrices (S,P), where S and P are upper triangular. +* Matrix pairs of this type are produced by the generalized Schur +* factorization of a complex matrix pair (A,B): +* +* A = Q*S*Z**H, B = Q*P*Z**H +* +* as computed by ZGGHRD + ZHGEQZ. +* +* The right eigenvector x and the left eigenvector y of (S,P) +* corresponding to an eigenvalue w are defined by: +* +* S*x = w*P*x, (y**H)*S = w*(y**H)*P, +* * where y**H denotes the conjugate tranpose of y. -* -* If an eigenvalue w is determined by zero diagonal elements of both A -* and B, a unit vector is returned as the corresponding eigenvector. -* -* If all eigenvectors are requested, the routine may either return -* the matrices X and/or Y of right or left eigenvectors of (A,B), or -* the products Z*X and/or Q*Y, where Z and Q are input unitary -* matrices. If (A,B) was obtained from the generalized Schur -* factorization of an original pair of matrices -* (A0,B0) = (Q*A*Z**H,Q*B*Z**H), -* then Z*X and Q*Y are the matrices of right or left eigenvectors of -* A. +* The eigenvalues are not input to this routine, but are computed +* directly from the diagonal elements of S and P. +* +* This routine returns the matrices X and/or Y of right and left +* eigenvectors of (S,P), or the products Z*X and/or Q*Y, +* where Z and Q are input matrices. +* If Q and Z are the unitary factors from the generalized Schur +* factorization of a matrix pair (A,B), then Z*X and Q*Y +* are the matrices of right and left eigenvectors of (A,B). * * Arguments * ========= @@ -54,66 +56,66 @@ * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; -* = 'B': compute all right and/or left eigenvectors, and -* backtransform them using the input matrices supplied -* in VR and/or VL; +* = 'B': compute all right and/or left eigenvectors, +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY='S', SELECT specifies the eigenvectors to be -* computed. -* If HOWMNY='A' or 'B', SELECT is not referenced. -* To select the eigenvector corresponding to the j-th -* eigenvalue, SELECT(j) must be set to .TRUE.. +* 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 matrices A and B. N >= 0. -* -* A (input) COMPLEX*16 array, dimension (LDA,N) -* The upper triangular matrix A. -* -* LDA (input) INTEGER -* The leading dimension of array A. LDA >= max(1,N). +* The order of the matrices S and P. N >= 0. * -* B (input) COMPLEX*16 array, dimension (LDB,N) -* The upper triangular matrix B. B must have real diagonal -* elements. +* S (input) COMPLEX*16 array, dimension (LDS,N) +* The upper triangular matrix S from a generalized Schur +* factorization, as computed by ZHGEQZ. +* +* LDS (input) INTEGER +* The leading dimension of array S. LDS >= max(1,N). +* +* P (input) COMPLEX*16 array, dimension (LDP,N) +* The upper triangular matrix P from a generalized Schur +* factorization, as computed by ZHGEQZ. P must have real +* diagonal elements. * -* LDB (input) INTEGER -* The leading dimension of array B. LDB >= max(1,N). +* LDP (input) INTEGER +* The leading dimension of array P. LDP >= 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 left Schur vectors returned by ZHGEQZ). * On exit, if SIDE = 'L' or 'B', VL contains: -* if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Q*Y; -* if HOWMNY = 'S', the left eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VL, in the same order as their eigenvalues. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of array VL. -* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of array VL. LDVL >= 1, and if +* SIDE = 'L' or 'l' or 'B' 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 Z * of right Schur vectors returned by ZHGEQZ). * On exit, if SIDE = 'R' or 'B', VR contains: -* if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Z*X; -* if HOWMNY = 'S', the right eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VR, in the same order as their eigenvalues. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. -* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. @@ -180,7 +182,7 @@ IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. - ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN + ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. @@ -211,9 +213,9 @@ INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN @@ -237,7 +239,7 @@ * ILBBAD = .FALSE. DO 20 J = 1, N - IF( DIMAG( B( J, J ) ).NE.ZERO ) + IF( DIMAG( P( J, J ) ).NE.ZERO ) $ ILBBAD = .TRUE. 20 CONTINUE * @@ -275,19 +277,19 @@ * part of A and B to check for possible overflow in the triangular * solver. * - ANORM = ABS1( A( 1, 1 ) ) - BNORM = ABS1( B( 1, 1 ) ) + ANORM = ABS1( S( 1, 1 ) ) + BNORM = ABS1( P( 1, 1 ) ) RWORK( 1 ) = ZERO RWORK( N+1 ) = ZERO DO 40 J = 2, N RWORK( J ) = ZERO RWORK( N+J ) = ZERO DO 30 I = 1, J - 1 - RWORK( J ) = RWORK( J ) + ABS1( A( I, J ) ) - RWORK( N+J ) = RWORK( N+J ) + ABS1( B( I, J ) ) + RWORK( J ) = RWORK( J ) + ABS1( S( I, J ) ) + RWORK( N+J ) = RWORK( N+J ) + ABS1( P( I, J ) ) 30 CONTINUE - ANORM = MAX( ANORM, RWORK( J )+ABS1( A( J, J ) ) ) - BNORM = MAX( BNORM, RWORK( N+J )+ABS1( B( J, J ) ) ) + ANORM = MAX( ANORM, RWORK( J )+ABS1( S( J, J ) ) ) + BNORM = MAX( BNORM, RWORK( N+J )+ABS1( P( J, J ) ) ) 40 CONTINUE * ASCALE = ONE / MAX( ANORM, SAFMIN ) @@ -309,8 +311,8 @@ IF( ILCOMP ) THEN IEIG = IEIG + 1 * - IF( ABS1( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( DBLE( B( JE, JE ) ) ).LE.SAFMIN ) THEN + IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * @@ -326,10 +328,10 @@ * H * y ( a A - b B ) = 0 * - TEMP = ONE / MAX( ABS1( A( JE, JE ) )*ASCALE, - $ ABS( DBLE( B( JE, JE ) ) )*BSCALE, SAFMIN ) - SALPHA = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*DBLE( B( JE, JE ) ) )*BSCALE + TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, + $ ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN ) + SALPHA = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * @@ -380,7 +382,7 @@ * * Compute * j-1 -* SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) +* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * (Scale if necessary) * @@ -396,16 +398,16 @@ SUMB = CZERO * DO 80 JR = JE, J - 1 - SUMA = SUMA + DCONJG( A( JR, J ) )*WORK( JR ) - SUMB = SUMB + DCONJG( B( JR, J ) )*WORK( JR ) + SUMA = SUMA + DCONJG( S( JR, J ) )*WORK( JR ) + SUMB = SUMB + DCONJG( P( JR, J ) )*WORK( JR ) 80 CONTINUE SUM = ACOEFF*SUMA - DCONJG( BCOEFF )*SUMB * -* Form x(j) = - SUM / conjg( a*A(j,j) - b*B(j,j) ) +* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) * * with scaling and perturbation of the denominator * - D = DCONJG( ACOEFF*A( J, J )-BCOEFF*B( J, J ) ) + D = DCONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) ) IF( ABS1( D ).LE.DMIN ) $ D = DCMPLX( DMIN ) * @@ -475,8 +477,8 @@ IF( ILCOMP ) THEN IEIG = IEIG - 1 * - IF( ABS1( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( DBLE( B( JE, JE ) ) ).LE.SAFMIN ) THEN + IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * @@ -492,10 +494,10 @@ * * ( a A - b B ) x = 0 * - TEMP = ONE / MAX( ABS1( A( JE, JE ) )*ASCALE, - $ ABS( DBLE( B( JE, JE ) ) )*BSCALE, SAFMIN ) - SALPHA = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*DBLE( B( JE, JE ) ) )*BSCALE + TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, + $ ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN ) + SALPHA = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * @@ -542,7 +544,7 @@ * WORK(j+1:JE) contains x * DO 170 JR = 1, JE - 1 - WORK( JR ) = ACOEFF*A( JR, JE ) - BCOEFF*B( JR, JE ) + WORK( JR ) = ACOEFF*S( JR, JE ) - BCOEFF*P( JR, JE ) 170 CONTINUE WORK( JE ) = CONE * @@ -551,7 +553,7 @@ * Form x(j) := - w(j) / d * with scaling and perturbation of the denominator * - D = ACOEFF*A( J, J ) - BCOEFF*B( J, J ) + D = ACOEFF*S( J, J ) - BCOEFF*P( J, J ) IF( ABS1( D ).LE.DMIN ) $ D = DCMPLX( DMIN ) * @@ -568,7 +570,7 @@ * IF( J.GT.1 ) THEN * -* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling +* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( ABS1( WORK( J ) ).GT.ONE ) THEN TEMP = ONE / ABS1( WORK( J ) ) @@ -583,8 +585,8 @@ CA = ACOEFF*WORK( J ) CB = BCOEFF*WORK( J ) DO 200 JR = 1, J - 1 - WORK( JR ) = WORK( JR ) + CA*A( JR, J ) - - $ CB*B( JR, J ) + WORK( JR ) = WORK( JR ) + CA*S( JR, J ) - + $ CB*P( JR, J ) 200 CONTINUE END IF 210 CONTINUE diff -uNr LAPACK.orig/SRC/ztrevc.f LAPACK/SRC/ztrevc.f --- LAPACK.orig/SRC/ztrevc.f Thu Nov 4 14:25:39 1999 +++ LAPACK/SRC/ztrevc.f Fri May 25 16:14:01 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 7, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -22,20 +22,23 @@ * * 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'*T = w*y' -* -* where y' denotes the conjugate transpose of the vector y. -* -* If all eigenvectors are requested, the routine may either return the -* matrices X and/or Y of right or left eigenvectors of T, or the -* products Q*X and/or Q*Y, where Q is an input unitary -* matrix. If T was obtained from the Schur factorization of an -* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of -* right or left eigenvectors of A. +* +* T*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 * ========= @@ -48,17 +51,17 @@ * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, -* and backtransform them using the input matrices -* supplied in VR and/or VL; +* backtransformed using the matrices supplied in +* VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, -* specified by the logical array SELECT. +* as indicated by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. -* If HOWMNY = 'A' or 'B', SELECT is not referenced. -* To select the eigenvector corresponding to the j-th -* eigenvalue, SELECT(j) must be set to .TRUE.. +* 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. @@ -76,19 +79,16 @@ * 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; -* VL is lower triangular. The i-th column -* VL(i) of VL is the eigenvector corresponding -* to T(i,i). * 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. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of the array VL. LDVL >= max(1,N) if -* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* 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 @@ -96,19 +96,16 @@ * 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; -* VR is upper triangular. The i-th column -* VR(i) of VR is the eigenvector corresponding -* to T(i,i). * 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. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. LDVR >= max(1,N) if -* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. diff -uNr LAPACK.orig/SRC/ztrsen.f LAPACK/SRC/ztrsen.f --- LAPACK.orig/SRC/ztrsen.f Thu Nov 4 14:25:39 1999 +++ LAPACK/SRC/ztrsen.f Fri May 25 16:14:20 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* January 3, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB @@ -93,14 +93,13 @@ * If JOB = 'N' or 'E', SEP is not referenced. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) -* If JOB = 'N', WORK is not referenced. Otherwise, -* on exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= 1; -* if JOB = 'E', LWORK = M*(N-M); -* if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). +* if JOB = 'E', LWORK = max(1,M*(N-M)); +* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns diff -uNr LAPACK.orig/SRC/ztrsyl.f LAPACK/SRC/ztrsyl.f --- LAPACK.orig/SRC/ztrsyl.f Thu Nov 4 14:25:39 1999 +++ LAPACK/SRC/ztrsyl.f Fri May 25 16:14:31 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* January 9, 2001 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB @@ -119,11 +119,9 @@ NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 - IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. - $ LSAME( TRANA, 'C' ) ) THEN + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -1 - ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. - $ LSAME( TRANB, 'C' ) ) THEN + ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 diff -uNr LAPACK.orig/TESTING/EIG/cerrgg.f LAPACK/TESTING/EIG/cerrgg.f --- LAPACK.orig/TESTING/EIG/cerrgg.f Thu Nov 4 14:27:30 1999 +++ LAPACK/TESTING/EIG/cerrgg.f Fri May 25 16:17:13 2001 @@ -3,7 +3,7 @@ * -- LAPACK test routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* October 9, 2000 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -245,24 +245,24 @@ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, INFO ) CALL CHKXER( 'CGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL CGGSVD( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 0, B, + CALL CGGSVD( 'N', 'N', 'N', 2, 1, 1, DUMMYK, DUMMYL, A, 1, B, $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, INFO ) CALL CHKXER( 'CGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 12 - CALL CGGSVD( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 0, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, INFO ) + CALL CGGSVD( 'N', 'N', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, INFO ) CALL CHKXER( 'CGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 16 - CALL CGGSVD( 'U', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 0, V, 1, Q, 1, W, RW, IW, INFO ) + CALL CGGSVD( 'U', 'N', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, + $ 2, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, INFO ) CALL CHKXER( 'CGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 18 - CALL CGGSVD( 'N', 'V', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 0, Q, 1, W, RW, IW, INFO ) + CALL CGGSVD( 'N', 'V', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, + $ 2, R1, R2, U, 2, V, 1, Q, 1, W, RW, IW, INFO ) CALL CHKXER( 'CGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 20 - CALL CGGSVD( 'N', 'N', 'Q', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 0, W, RW, IW, INFO ) + CALL CGGSVD( 'N', 'N', 'Q', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, + $ 2, R1, R2, U, 2, V, 2, Q, 1, W, RW, IW, INFO ) CALL CHKXER( 'CGGSVD', INFOT, NOUT, LERR, OK ) NT = NT + 11 * @@ -300,28 +300,28 @@ $ INFO ) CALL CHKXER( 'CGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CGGSVP( 'N', 'N', 'N', 0, 0, 0, A, 0, B, 1, TOLA, TOLB, + CALL CGGSVP( 'N', 'N', 'N', 2, 1, 1, A, 1, B, 1, TOLA, TOLB, $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, RW, TAU, W, $ INFO ) CALL CHKXER( 'CGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL CGGSVP( 'N', 'N', 'N', 0, 0, 0, A, 1, B, 0, TOLA, TOLB, + CALL CGGSVP( 'N', 'N', 'N', 1, 2, 1, A, 1, B, 1, TOLA, TOLB, $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, RW, TAU, W, $ INFO ) CALL CHKXER( 'CGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 16 - CALL CGGSVP( 'U', 'N', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB, - $ DUMMYK, DUMMYL, U, 0, V, 1, Q, 1, IW, RW, TAU, W, + CALL CGGSVP( 'U', 'N', 'N', 2, 2, 2, A, 2, B, 2, TOLA, TOLB, + $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, RW, TAU, W, $ INFO ) CALL CHKXER( 'CGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 18 - CALL CGGSVP( 'N', 'V', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB, - $ DUMMYK, DUMMYL, U, 1, V, 0, Q, 1, IW, RW, TAU, W, + CALL CGGSVP( 'N', 'V', 'N', 2, 2, 2, A, 2, B, 2, TOLA, TOLB, + $ DUMMYK, DUMMYL, U, 2, V, 1, Q, 1, IW, RW, TAU, W, $ INFO ) CALL CHKXER( 'CGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 20 - CALL CGGSVP( 'N', 'N', 'Q', 0, 0, 0, A, 1, B, 1, TOLA, TOLB, - $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 0, IW, RW, TAU, W, + CALL CGGSVP( 'N', 'N', 'Q', 2, 2, 2, A, 2, B, 2, TOLA, TOLB, + $ DUMMYK, DUMMYL, U, 2, V, 2, Q, 1, IW, RW, TAU, W, $ INFO ) CALL CHKXER( 'CGGSVP', INFOT, NOUT, LERR, OK ) NT = NT + 11 diff -uNr LAPACK.orig/TESTING/EIG/derrgg.f LAPACK/TESTING/EIG/derrgg.f --- LAPACK.orig/TESTING/EIG/derrgg.f Thu Nov 4 14:27:53 1999 +++ LAPACK/TESTING/EIG/derrgg.f Fri May 25 16:17:09 2001 @@ -3,7 +3,7 @@ * -- LAPACK test routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* October 9, 2000 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -244,24 +244,24 @@ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL DGGSVD( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 0, B, + CALL DGGSVD( 'N', 'N', 'N', 2, 1, 1, DUMMYK, DUMMYL, A, 1, B, $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 12 - CALL DGGSVD( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 0, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) + CALL DGGSVD( 'N', 'N', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 16 - CALL DGGSVD( 'U', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 0, V, 1, Q, 1, W, IW, INFO ) + CALL DGGSVD( 'U', 'N', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, + $ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 18 - CALL DGGSVD( 'N', 'V', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 0, Q, 1, W, IW, INFO ) + CALL DGGSVD( 'N', 'V', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B, + $ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 20 - CALL DGGSVD( 'N', 'N', 'Q', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 0, W, IW, INFO ) + CALL DGGSVD( 'N', 'N', 'Q', 1, 2, 1, DUMMYK, DUMMYL, A, 1, B, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK ) NT = NT + 11 * @@ -299,28 +299,28 @@ $ INFO ) CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL DGGSVP( 'N', 'N', 'N', 0, 0, 0, A, 0, B, 1, TOLA, TOLB, + CALL DGGSVP( 'N', 'N', 'N', 2, 1, 1, A, 1, B, 1, TOLA, TOLB, $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W, $ INFO ) CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL DGGSVP( 'N', 'N', 'N', 0, 0, 0, A, 1, B, 0, TOLA, TOLB, + CALL DGGSVP( 'N', 'N', 'N', 1, 2, 1, A, 1, B, 1, TOLA, TOLB, $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W, $ INFO ) CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 16 - CALL DGGSVP( 'U', 'N', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB, - $ DUMMYK, DUMMYL, U, 0, V, 1, Q, 1, IW, TAU, W, + CALL DGGSVP( 'U', 'N', 'N', 2, 2, 2, A, 2, B, 2, TOLA, TOLB, + $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W, $ INFO ) CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 18 - CALL DGGSVP( 'N', 'V', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB, - $ DUMMYK, DUMMYL, U, 1, V, 0, Q, 1, IW, TAU, W, + CALL DGGSVP( 'N', 'V', 'N', 1, 2, 1, A, 1, B, 2, TOLA, TOLB, + $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W, $ INFO ) CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 20 - CALL DGGSVP( 'N', 'N', 'Q', 0, 0, 0, A, 1, B, 1, TOLA, TOLB, - $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 0, IW, TAU, W, + CALL DGGSVP( 'N', 'N', 'Q', 1, 1, 2, A, 1, B, 1, TOLA, TOLB, + $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W, $ INFO ) CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK ) NT = NT + 11 @@ -501,11 +501,11 @@ CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK ) NT = NT + 6 * -* Test error exits for the DGS, DGV, DGX, and DXV paths. +* Test error exits for the SGS, SGV, SGX, and SXV paths. * - ELSE IF( LSAMEN( 3, PATH, 'DGS' ) .OR. - $ LSAMEN( 3, PATH, 'DGV' ) .OR. - $ LSAMEN( 3, PATH, 'DGX' ) .OR. LSAMEN( 3, PATH, 'DXV' ) ) + ELSE IF( LSAMEN( 3, PATH, 'SGS' ) .OR. + $ LSAMEN( 3, PATH, 'SGV' ) .OR. + $ LSAMEN( 3, PATH, 'SGX' ) .OR. LSAMEN( 3, PATH, 'SXV' ) ) $ THEN * * DGGES diff -uNr LAPACK.orig/TESTING/EIG/serrgg.f LAPACK/TESTING/EIG/serrgg.f --- LAPACK.orig/TESTING/EIG/serrgg.f Thu Nov 4 14:27:25 1999 +++ LAPACK/TESTING/EIG/serrgg.f Fri May 25 16:17:05 2001 @@ -3,7 +3,7 @@ * -- LAPACK test routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* October 9, 2000 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -244,24 +244,24 @@ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL SGGSVD( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 0, B, + CALL SGGSVD( 'N', 'N', 'N', 2, 1, 1, DUMMYK, DUMMYL, A, 1, B, $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 12 - CALL SGGSVD( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 0, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) + CALL SGGSVD( 'N', 'N', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 16 - CALL SGGSVD( 'U', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 0, V, 1, Q, 1, W, IW, INFO ) + CALL SGGSVD( 'U', 'N', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, + $ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 18 - CALL SGGSVD( 'N', 'V', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 0, Q, 1, W, IW, INFO ) + CALL SGGSVD( 'N', 'V', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B, + $ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 20 - CALL SGGSVD( 'N', 'N', 'Q', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 0, W, IW, INFO ) + CALL SGGSVD( 'N', 'N', 'Q', 1, 2, 1, DUMMYK, DUMMYL, A, 1, B, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO ) CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK ) NT = NT + 11 * @@ -299,28 +299,28 @@ $ INFO ) CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL SGGSVP( 'N', 'N', 'N', 0, 0, 0, A, 0, B, 1, TOLA, TOLB, + CALL SGGSVP( 'N', 'N', 'N', 2, 1, 1, A, 1, B, 1, TOLA, TOLB, $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W, $ INFO ) CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL SGGSVP( 'N', 'N', 'N', 0, 0, 0, A, 1, B, 0, TOLA, TOLB, + CALL SGGSVP( 'N', 'N', 'N', 1, 2, 1, A, 1, B, 1, TOLA, TOLB, $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W, $ INFO ) CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 16 - CALL SGGSVP( 'U', 'N', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB, - $ DUMMYK, DUMMYL, U, 0, V, 1, Q, 1, IW, TAU, W, + CALL SGGSVP( 'U', 'N', 'N', 2, 2, 2, A, 2, B, 2, TOLA, TOLB, + $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W, $ INFO ) CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 18 - CALL SGGSVP( 'N', 'V', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB, - $ DUMMYK, DUMMYL, U, 1, V, 0, Q, 1, IW, TAU, W, + CALL SGGSVP( 'N', 'V', 'N', 1, 2, 1, A, 1, B, 2, TOLA, TOLB, + $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W, $ INFO ) CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 20 - CALL SGGSVP( 'N', 'N', 'Q', 0, 0, 0, A, 1, B, 1, TOLA, TOLB, - $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 0, IW, TAU, W, + CALL SGGSVP( 'N', 'N', 'Q', 1, 1, 2, A, 1, B, 1, TOLA, TOLB, + $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W, $ INFO ) CALL CHKXER( 'SGGSVP', INFOT, NOUT, LERR, OK ) NT = NT + 11 diff -uNr LAPACK.orig/TESTING/EIG/zerrgg.f LAPACK/TESTING/EIG/zerrgg.f --- LAPACK.orig/TESTING/EIG/zerrgg.f Thu Nov 4 14:27:40 1999 +++ LAPACK/TESTING/EIG/zerrgg.f Fri May 25 16:17:20 2001 @@ -3,7 +3,7 @@ * -- LAPACK test routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* October 9, 2000 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -245,24 +245,24 @@ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, INFO ) CALL CHKXER( 'ZGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL ZGGSVD( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 0, B, + CALL ZGGSVD( 'N', 'N', 'N', 2, 1, 1, DUMMYK, DUMMYL, A, 1, B, $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, INFO ) CALL CHKXER( 'ZGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 12 - CALL ZGGSVD( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 0, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, INFO ) + CALL ZGGSVD( 'N', 'N', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B, + $ 1, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, INFO ) CALL CHKXER( 'ZGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 16 - CALL ZGGSVD( 'U', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 0, V, 1, Q, 1, W, RW, IW, INFO ) + CALL ZGGSVD( 'U', 'N', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, + $ 2, R1, R2, U, 1, V, 1, Q, 1, W, RW, IW, INFO ) CALL CHKXER( 'ZGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 18 - CALL ZGGSVD( 'N', 'V', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 0, Q, 1, W, RW, IW, INFO ) + CALL ZGGSVD( 'N', 'V', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, + $ 2, R1, R2, U, 2, V, 1, Q, 1, W, RW, IW, INFO ) CALL CHKXER( 'ZGGSVD', INFOT, NOUT, LERR, OK ) INFOT = 20 - CALL ZGGSVD( 'N', 'N', 'Q', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B, - $ 1, R1, R2, U, 1, V, 1, Q, 0, W, RW, IW, INFO ) + CALL ZGGSVD( 'N', 'N', 'Q', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B, + $ 2, R1, R2, U, 2, V, 2, Q, 1, W, RW, IW, INFO ) CALL CHKXER( 'ZGGSVD', INFOT, NOUT, LERR, OK ) NT = NT + 11 * @@ -300,28 +300,28 @@ $ INFO ) CALL CHKXER( 'ZGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL ZGGSVP( 'N', 'N', 'N', 0, 0, 0, A, 0, B, 1, TOLA, TOLB, + CALL ZGGSVP( 'N', 'N', 'N', 2, 1, 1, A, 1, B, 1, TOLA, TOLB, $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, RW, TAU, W, $ INFO ) CALL CHKXER( 'ZGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL ZGGSVP( 'N', 'N', 'N', 0, 0, 0, A, 1, B, 0, TOLA, TOLB, + CALL ZGGSVP( 'N', 'N', 'N', 1, 2, 1, A, 1, B, 1, TOLA, TOLB, $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, RW, TAU, W, $ INFO ) CALL CHKXER( 'ZGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 16 - CALL ZGGSVP( 'U', 'N', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB, - $ DUMMYK, DUMMYL, U, 0, V, 1, Q, 1, IW, RW, TAU, W, + CALL ZGGSVP( 'U', 'N', 'N', 2, 2, 2, A, 2, B, 2, TOLA, TOLB, + $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, RW, TAU, W, $ INFO ) CALL CHKXER( 'ZGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 18 - CALL ZGGSVP( 'N', 'V', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB, - $ DUMMYK, DUMMYL, U, 1, V, 0, Q, 1, IW, RW, TAU, W, + CALL ZGGSVP( 'N', 'V', 'N', 2, 2, 2, A, 2, B, 2, TOLA, TOLB, + $ DUMMYK, DUMMYL, U, 2, V, 1, Q, 1, IW, RW, TAU, W, $ INFO ) CALL CHKXER( 'ZGGSVP', INFOT, NOUT, LERR, OK ) INFOT = 20 - CALL ZGGSVP( 'N', 'N', 'Q', 0, 0, 0, A, 1, B, 1, TOLA, TOLB, - $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 0, IW, RW, TAU, W, + CALL ZGGSVP( 'N', 'N', 'Q', 2, 2, 2, A, 2, B, 2, TOLA, TOLB, + $ DUMMYK, DUMMYL, U, 2, V, 2, Q, 1, IW, RW, TAU, W, $ INFO ) CALL CHKXER( 'ZGGSVP', INFOT, NOUT, LERR, OK ) NT = NT + 11 @@ -518,11 +518,11 @@ CALL CHKXER( 'ZGGRQF', INFOT, NOUT, LERR, OK ) NT = NT + 6 * -* Test error exits for the ZGS, ZGV, ZGX, and ZXV paths. +* Test error exits for the CGS, CGV, CGX, and CXV paths. * - ELSE IF( LSAMEN( 3, PATH, 'ZGS' ) .OR. - $ LSAMEN( 3, PATH, 'ZGV' ) .OR. - $ LSAMEN( 3, PATH, 'ZGX' ) .OR. LSAMEN( 3, PATH, 'ZXV' ) ) + ELSE IF( LSAMEN( 3, PATH, 'CGS' ) .OR. + $ LSAMEN( 3, PATH, 'CGV' ) .OR. + $ LSAMEN( 3, PATH, 'CGX' ) .OR. LSAMEN( 3, PATH, 'CXV' ) ) $ THEN * * ZGGES diff -uNr LAPACK.orig/TESTING/LIN/cerrqp.f LAPACK/TESTING/LIN/cerrqp.f --- LAPACK.orig/TESTING/LIN/cerrqp.f Thu Nov 4 14:26:53 1999 +++ LAPACK/TESTING/LIN/cerrqp.f Fri May 25 16:15:32 2001 @@ -3,7 +3,7 @@ * -- LAPACK test routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* October 6, 2000 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -28,7 +28,7 @@ * * .. Parameters .. INTEGER NMAX - PARAMETER ( NMAX = 2 ) + PARAMETER ( NMAX = 3 ) * .. * .. Local Scalars .. CHARACTER*2 C2 @@ -98,10 +98,10 @@ CALL CGEQP3( 1, -1, A, 1, IP, TAU, W, LW, RW, INFO ) CALL CHKXER( 'CGEQP3', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEQP3( 1, 1, A, 0, IP, TAU, W, LW, RW, INFO ) + CALL CGEQP3( 2, 3, A, 1, IP, TAU, W, LW, RW, INFO ) CALL CHKXER( 'CGEQP3', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CGEQP3( 2, 2, A, 2, IP, TAU, W, LW-1, RW, INFO ) + CALL CGEQP3( 2, 2, A, 2, IP, TAU, W, LW-10, RW, INFO ) CALL CHKXER( 'CGEQP3', INFOT, NOUT, LERR, OK ) END IF * diff -uNr LAPACK.orig/TESTING/LIN/derrqp.f LAPACK/TESTING/LIN/derrqp.f --- LAPACK.orig/TESTING/LIN/derrqp.f Thu Nov 4 14:27:03 1999 +++ LAPACK/TESTING/LIN/derrqp.f Fri May 25 16:15:28 2001 @@ -3,7 +3,7 @@ * -- LAPACK test routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* October 6, 2000 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -13,7 +13,7 @@ * Purpose * ======= * -* DERRQP tests the error exits for DGEQPF and SGEQP3. +* DERRQP tests the error exits for DGEQPF and DGEQP3. * * Arguments * ========= @@ -28,7 +28,7 @@ * * .. Parameters .. INTEGER NMAX - PARAMETER ( NMAX = 2 ) + PARAMETER ( NMAX = 3 ) * .. * .. Local Scalars .. CHARACTER*2 C2 @@ -93,10 +93,10 @@ CALL DGEQP3( 1, -1, A, 1, IP, TAU, W, LW, INFO ) CALL CHKXER( 'DGEQP3', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DGEQP3( 1, 2, A, 0, IP, TAU, W, LW, INFO ) + CALL DGEQP3( 2, 3, A, 1, IP, TAU, W, LW, INFO ) CALL CHKXER( 'DGEQP3', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL DGEQP3( 2, 2, A, 2, IP, TAU, W, LW-1, INFO ) + CALL DGEQP3( 2, 2, A, 2, IP, TAU, W, LW-10, INFO ) CALL CHKXER( 'DGEQP3', INFOT, NOUT, LERR, OK ) END IF * diff -uNr LAPACK.orig/TESTING/LIN/serrqp.f LAPACK/TESTING/LIN/serrqp.f --- LAPACK.orig/TESTING/LIN/serrqp.f Thu Nov 4 14:26:44 1999 +++ LAPACK/TESTING/LIN/serrqp.f Fri May 25 16:15:23 2001 @@ -3,7 +3,7 @@ * -- LAPACK test routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* October 6, 2000 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -28,7 +28,7 @@ * * .. Parameters .. INTEGER NMAX - PARAMETER ( NMAX = 2 ) + PARAMETER ( NMAX = 3 ) * .. * .. Local Scalars .. CHARACTER*2 C2 @@ -93,10 +93,10 @@ CALL SGEQP3( 1, -1, A, 1, IP, TAU, W, LW, INFO ) CALL CHKXER( 'SGEQP3', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL SGEQP3( 1, 2, A, 0, IP, TAU, W, LW, INFO ) + CALL SGEQP3( 2, 3, A, 1, IP, TAU, W, LW, INFO ) CALL CHKXER( 'SGEQP3', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL SGEQP3( 2, 2, A, 2, IP, TAU, W, LW-1, INFO ) + CALL SGEQP3( 2, 2, A, 2, IP, TAU, W, LW-10, INFO ) CALL CHKXER( 'SGEQP3', INFOT, NOUT, LERR, OK ) END IF * diff -uNr LAPACK.orig/TESTING/LIN/zerrqp.f LAPACK/TESTING/LIN/zerrqp.f --- LAPACK.orig/TESTING/LIN/zerrqp.f Thu Nov 4 14:27:13 1999 +++ LAPACK/TESTING/LIN/zerrqp.f Fri May 25 16:15:36 2001 @@ -3,7 +3,7 @@ * -- LAPACK test routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* October 6, 2000 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -28,7 +28,7 @@ * * .. Parameters .. INTEGER NMAX - PARAMETER ( NMAX = 2 ) + PARAMETER ( NMAX = 3 ) * .. * .. Local Scalars .. CHARACTER*2 C2 @@ -98,10 +98,10 @@ CALL ZGEQP3( 1, -1, A, 1, IP, TAU, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQP3', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEQP3( 1, 1, A, 0, IP, TAU, W, LW, RW, INFO ) + CALL ZGEQP3( 2, 3, A, 1, IP, TAU, W, LW, RW, INFO ) CALL CHKXER( 'ZGEQP3', INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL ZGEQP3( 2, 2, A, 2, IP, TAU, W, LW-1, RW, INFO ) + CALL ZGEQP3( 2, 2, A, 2, IP, TAU, W, LW-10, RW, INFO ) CALL CHKXER( 'ZGEQP3', INFOT, NOUT, LERR, OK ) END IF * diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/cbdsqr.f LAPACK/TIMING/EIG/EIGSRC/cbdsqr.f --- LAPACK.orig/TIMING/EIG/EIGSRC/cbdsqr.f Thu Nov 4 14:28:26 1999 +++ LAPACK/TIMING/EIG/EIGSRC/cbdsqr.f Fri May 25 16:19:57 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. CHARACTER UPLO @@ -26,14 +26,26 @@ * Purpose * ======= * -* CBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. -* -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given complex input matrices U, VT, and C. +* CBDSQR 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 CGEBRD, 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, @@ -69,18 +81,17 @@ * order. * * E (input/output) REAL array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E +* 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. E(N) is used for workspace. * * VT (input/output) COMPLEX array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. +* On exit, VT is overwritten by P**H * VT. +* Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. @@ -89,21 +100,22 @@ * U (input/output) COMPLEX array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. -* U is not referenced if NRU = 0. +* Not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) COMPLEX array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. -* On exit, C is overwritten by Q' * C. -* C is not referenced if NCC = 0. +* 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) REAL array, dimension (4*N) +* RWORK (workspace) REAL array, dimension (2*N) +* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise * * INFO (output) INTEGER * = 0: successful exit diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/cgghrd.f LAPACK/TIMING/EIG/EIGSRC/cgghrd.f --- LAPACK.orig/TIMING/EIG/EIGSRC/cgghrd.f Thu Nov 4 14:28:26 1999 +++ LAPACK/TIMING/EIG/EIGSRC/cgghrd.f Fri May 25 16:20:17 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ @@ -33,16 +33,29 @@ * * CGGHRD reduces a pair of complex matrices (A,B) to generalized upper * Hessenberg form using unitary transformations, where A is a -* general matrix and B is upper triangular: Q' * A * Z = H and -* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, -* and Q and Z are unitary, and ' means conjugate transpose. +* general matrix and B is upper triangular. The form of the generalized +* eigenvalue problem is +* A*x = lambda*B*x, +* and B is typically made upper triangular by computing its QR +* factorization and moving the unitary matrix Q to the left side +* of the equation. +* +* This subroutine simultaneously reduces A to a Hessenberg matrix H: +* Q**H*A*Z = H +* and transforms B to another upper triangular matrix T: +* Q**H*B*Z = T +* in order to reduce the problem to its standard form +* H*y = lambda*T*y +* where y = Z**H*x. * * The unitary matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be * postmultiplied into input matrices Q1 and Z1, so that -* -* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' -* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' +* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H +* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H +* If Q1 is the unitary matrix from the QR factorization of B in the +* original equation A*x = lambda*B*x, then CGGHRD reduces the original +* problem to generalized Hessenberg form. * * Arguments * ========= @@ -66,10 +79,11 @@ * * 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 CGGBAL; otherwise they should be set -* to 1 and N respectively. +* ILO and IHI mark the rows and columns of A which are to be +* reduced. 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 CGGBAL; otherwise they +* should be set to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) COMPLEX array, dimension (LDA, N) @@ -83,33 +97,28 @@ * * B (input/output) COMPLEX array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. -* On exit, the upper triangular matrix T = Q' B Z. The +* On exit, the upper triangular matrix T = Q**H B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) COMPLEX array, dimension (LDQ, N) -* If COMPQ='N': Q is not referenced. -* If COMPQ='I': on entry, Q need not be set, and on exit it -* contains the unitary matrix Q, where Q' -* is the product of the Givens transformations -* which are applied to A and B on the left. -* If COMPQ='V': on entry, Q must contain a unitary matrix -* Q1, and on exit this is overwritten by Q1*Q. +* On entry, if COMPQ = 'V', the unitary matrix Q1, typically +* from the QR factorization of B. +* On exit, if COMPQ='I', the unitary matrix Q, and if +* COMPQ = 'V', the product Q1*Q. +* Not referenced if COMPQ='N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * Z (input/output) COMPLEX array, dimension (LDZ, N) -* If COMPZ='N': Z is not referenced. -* If COMPZ='I': on entry, Z need not be set, and on exit it -* contains the unitary matrix Z, which is -* the product of the Givens transformations -* which are applied to A and B on the right. -* If COMPZ='V': on entry, Z must contain a unitary matrix -* Z1, and on exit this is overwritten by Z1*Z. +* On entry, if COMPZ = 'V', the unitary matrix Z1. +* On exit, if COMPZ='I', the unitary matrix Z, and if +* COMPZ = 'V', the product Z1*Z. +* Not referenced if COMPZ='N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/chgeqz.f LAPACK/TIMING/EIG/EIGSRC/chgeqz.f --- LAPACK.orig/TIMING/EIG/EIGSRC/chgeqz.f Thu Nov 4 14:28:26 1999 +++ LAPACK/TIMING/EIG/EIGSRC/chgeqz.f Fri May 25 16:20:35 2001 @@ -1,20 +1,21 @@ - SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, + SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, $ RWORK, INFO ) * * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 3, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. REAL RWORK( * ) - COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), - $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) + COMPLEX ALPHA( * ), BETA( * ), H( LDH, * ), + $ Q( LDQ, * ), T( LDT, * ), WORK( * ), + $ Z( LDZ, * ) * .. * * ----------------------- Begin Timing Code ------------------------ @@ -34,24 +35,44 @@ * Purpose * ======= * -* CHGEQZ implements a single-shift version of the QZ -* method for finding the generalized eigenvalues w(i)=ALPHA(i)/BETA(i) -* of the equation -* -* det( A - w(i) B ) = 0 -* -* If JOB='S', then the pair (A,B) is simultaneously -* reduced to Schur form (i.e., A and B are both upper triangular) by -* applying one unitary tranformation (usually called Q) on the left and -* another (usually called Z) on the right. The diagonal elements of -* A are then ALPHA(1),...,ALPHA(N), and of B are BETA(1),...,BETA(N). -* -* If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the unitary -* transformations used to reduce (A,B) are accumulated into the arrays -* Q and Z s.t.: -* -* Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* -* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* +* CHGEQZ computes the eigenvalues of a complex matrix pair (H,T), +* where H is an upper Hessenberg matrix and T is upper triangular, +* using the single-shift QZ method. +* Matrix pairs of this type are produced by the reduction to +* generalized upper Hessenberg form of a complex matrix pair (A,B): +* +* A = Q1*H*Z1**H, B = Q1*T*Z1**H, +* +* as computed by CGGHRD. +* +* If JOB='S', then the Hessenberg-triangular pair (H,T) is +* also reduced to generalized Schur form, +* +* H = Q*S*Z**H, T = Q*P*Z**H, +* +* where Q and Z are unitary matrices and S and P are upper triangular. +* +* Optionally, the unitary matrix Q from the generalized Schur +* factorization may be postmultiplied into an input matrix Q1, and the +* unitary matrix Z may be postmultiplied into an input matrix Z1. +* If Q1 and Z1 are the unitary matrices from CGGHRD that reduced +* the matrix pair (A,B) to generalized Hessenberg form, then the output +* matrices Q1*Q and Z1*Z are the unitary factors from the generalized +* Schur factorization of (A,B): +* +* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. +* +* To avoid overflow, eigenvalues of the matrix pair (H,T) +* (equivalently, of (A,B)) are computed as a pair of complex values +* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an +* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) +* A*x = lambda*B*x +* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the +* alternate form of the GNEP +* mu*A*y = B*y. +* The values of alpha and beta for the i-th eigenvalue can be read +* directly from the generalized Schur form: alpha = S(i,i), +* beta = P(i,i). * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), @@ -61,83 +82,88 @@ * ========= * * JOB (input) CHARACTER*1 -* = 'E': compute only ALPHA and BETA. A and B will not -* necessarily be put into generalized Schur form. -* = 'S': put A and B into generalized Schur form, as well -* as computing ALPHA and BETA. +* = 'E': Compute eigenvalues only; +* = 'S': Computer eigenvalues and the Schur form. * * COMPQ (input) CHARACTER*1 -* = 'N': do not modify Q. -* = 'V': multiply the array Q on the right by the conjugate -* transpose of the unitary tranformation that is -* applied to the left side of A and B to reduce them -* to Schur form. -* = 'I': like COMPQ='V', except that Q will be initialized to -* the identity first. +* = 'N': Left Schur vectors (Q) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Q +* of left Schur vectors of (H,T) is returned; +* = 'V': Q must contain a unitary matrix Q1 on entry and +* the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 -* = 'N': do not modify Z. -* = 'V': multiply the array Z on the right by the unitary -* tranformation that is applied to the right side of -* A and B to reduce them to Schur form. -* = 'I': like COMPZ='V', except that Z will be initialized to -* the identity first. +* = 'N': Right Schur vectors (Z) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Z +* of right Schur vectors of (H,T) is returned; +* = 'V': Z must contain a unitary matrix Z1 on entry and +* the product Z1*Z is returned. * * N (input) INTEGER -* The order of the matrices A, B, Q, and Z. N >= 0. +* The order of the matrices H, T, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* A (input/output) COMPLEX array, dimension (LDA, N) -* On entry, the N-by-N upper Hessenberg matrix A. Elements -* below the subdiagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to upper triangular form. -* If JOB='E', then on exit A will have been destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max( 1, N ). -* -* B (input/output) COMPLEX array, dimension (LDB, N) -* On entry, the N-by-N upper triangular matrix B. Elements -* below the diagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to upper triangular form. -* If JOB='E', then on exit B will have been destroyed. +* ILO and IHI mark the rows and columns of H which are in +* Hessenberg form. It is assumed that A is already upper +* triangular in rows and columns 1:ILO-1 and IHI+1:N. +* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. +* +* H (input/output) COMPLEX array, dimension (LDH, N) +* On entry, the N-by-N upper Hessenberg matrix H. +* On exit, if JOB = 'S', H contains the upper triangular +* matrix S from the generalized Schur factorization. +* If JOB = 'E', the diagonal of H matches that of S, but +* the rest of H is unspecified. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH >= max( 1, N ). +* +* T (input/output) COMPLEX array, dimension (LDT, N) +* On entry, the N-by-N upper triangular matrix T. +* On exit, if JOB = 'S', T contains the upper triangular +* matrix P from the generalized Schur factorization. +* If JOB = 'E', the diagonal of T matches that of P, but +* the rest of T is unspecified. * -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max( 1, N ). +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max( 1, N ). * * ALPHA (output) COMPLEX array, dimension (N) -* The diagonal elements of A when the pair (A,B) has been -* reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N -* are the generalized eigenvalues. +* The complex scalars alpha that define the eigenvalues of +* GNEP. ALPHA(i) = S(i,i) in the generalized Schur +* factorization. * * BETA (output) COMPLEX array, dimension (N) -* The diagonal elements of B when the pair (A,B) has been -* reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N -* are the generalized eigenvalues. A and B are normalized -* so that BETA(1),...,BETA(N) are non-negative real numbers. +* The real non-negative scalars beta that define the +* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized +* Schur factorization. +* +* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) +* represent the j-th eigenvalue of the matrix pair (A,B), in +* one of the forms lambda = alpha/beta or mu = beta/alpha. +* Since either lambda or mu may overflow, they should not, +* in general, be computed. * * Q (input/output) COMPLEX array, dimension (LDQ, N) -* If COMPQ='N', then Q will not be referenced. -* If COMPQ='V' or 'I', then the conjugate transpose of the -* unitary transformations which are applied to A and B on -* the left will be applied to the array Q on the right. +* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the +* reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the unitary matrix of left Schur +* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of +* left Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) COMPLEX array, dimension (LDZ, N) -* If COMPZ='N', then Z will not be referenced. -* If COMPZ='V' or 'I', then the unitary transformations which -* are applied to A and B on the right will be applied to the -* array Z on the right. +* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the +* reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the unitary matrix of right Schur +* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of +* right Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. @@ -159,13 +185,12 @@ * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value -* = 1,...,N: the QZ iteration did not converge. (A,B) is not +* = 1,...,N: the QZ iteration did not converge. (H,T) is not * in Schur form, but ALPHA(i) and BETA(i), * i=INFO+1,...,N should be correct. -* = N+1,...,2*N: the shift calculation failed. (A,B) is not +* = N+1,...,2*N: the shift calculation failed. (H,T) is not * in Schur form, but ALPHA(i) and BETA(i), * i=INFO-N+1,...,N should be correct. -* > 2*N: various "impossible" errors. * * Further Details * =============== @@ -192,7 +217,7 @@ REAL ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL, $ C, OPST, SAFMIN, TEMP, TEMP2, TEMPR, ULP COMPLEX ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2, - $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T, + $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1, $ U12, X * .. * .. External Functions .. @@ -278,9 +303,9 @@ INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 - ELSE IF( LDA.LT.N ) THEN + ELSE IF( LDH.LT.N ) THEN INFO = -8 - ELSE IF( LDB.LT.N ) THEN + ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -14 @@ -316,8 +341,8 @@ IN = IHI + 1 - ILO SAFMIN = SLAMCH( 'S' ) ULP = SLAMCH( 'E' )*SLAMCH( 'B' ) - ANORM = CLANHS( 'F', IN, A( ILO, ILO ), LDA, RWORK ) - BNORM = CLANHS( 'F', IN, B( ILO, ILO ), LDB, RWORK ) + ANORM = CLANHS( 'F', IN, H( ILO, ILO ), LDH, RWORK ) + BNORM = CLANHS( 'F', IN, T( ILO, ILO ), LDT, RWORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) @@ -334,18 +359,18 @@ * Set Eigenvalues IHI+1:N * DO 10 J = IHI + 1, N - ABSB = ABS( B( J, J ) ) + ABSB = ABS( T( J, J ) ) IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = CONJG( B( J, J ) / ABSB ) - B( J, J ) = ABSB + SIGNBC = CONJG( T( J, J ) / ABSB ) + T( J, J ) = ABSB IF( ILSCHR ) THEN - CALL CSCAL( J-1, SIGNBC, B( 1, J ), 1 ) - CALL CSCAL( J, SIGNBC, A( 1, J ), 1 ) + CALL CSCAL( J-1, SIGNBC, T( 1, J ), 1 ) + CALL CSCAL( J, SIGNBC, H( 1, J ), 1 ) * ----------------- Begin Timing Code --------------------- OPST = OPST + REAL( 12*( J-1 ) ) * ------------------ End Timing Code ---------------------- ELSE - A( J, J ) = A( J, J )*SIGNBC + H( J, J ) = H( J, J )*SIGNBC END IF IF( ILZ ) $ CALL CSCAL( N, SIGNBC, Z( 1, J ), 1 ) @@ -353,10 +378,10 @@ OPST = OPST + REAL( 6*NZ+13 ) * -------------------- End Timing Code ----------------------- ELSE - B( J, J ) = CZERO + T( J, J ) = CZERO END IF - ALPHA( J ) = A( J, J ) - BETA( J ) = B( J, J ) + ALPHA( J ) = H( J, J ) + BETA( J ) = T( J, J ) 10 CONTINUE * * If IHI < ILO, skip QZ steps @@ -401,22 +426,22 @@ * Split the matrix if possible. * * Two tests: -* 1: A(j,j-1)=0 or j=ILO -* 2: B(j,j)=0 +* 1: H(j,j-1)=0 or j=ILO +* 2: T(j,j)=0 * * Special case: j=ILAST * IF( ILAST.EQ.ILO ) THEN GO TO 60 ELSE - IF( ABS1( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN - A( ILAST, ILAST-1 ) = CZERO + IF( ABS1( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = CZERO GO TO 60 END IF END IF * - IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN - B( ILAST, ILAST ) = CZERO + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = CZERO GO TO 50 END IF * @@ -424,30 +449,30 @@ * DO 40 J = ILAST - 1, ILO, -1 * -* Test 1: for A(j,j-1)=0 or j=ILO +* Test 1: for H(j,j-1)=0 or j=ILO * IF( J.EQ.ILO ) THEN ILAZRO = .TRUE. ELSE - IF( ABS1( A( J, J-1 ) ).LE.ATOL ) THEN - A( J, J-1 ) = CZERO + IF( ABS1( H( J, J-1 ) ).LE.ATOL ) THEN + H( J, J-1 ) = CZERO ILAZRO = .TRUE. ELSE ILAZRO = .FALSE. END IF END IF * -* Test 2: for B(j,j)=0 +* Test 2: for T(j,j)=0 * - IF( ABS( B( J, J ) ).LT.BTOL ) THEN - B( J, J ) = CZERO + IF( ABS( T( J, J ) ).LT.BTOL ) THEN + T( J, J ) = CZERO * * Test 1a: Check for 2 consecutive small subdiagonals in A * ILAZR2 = .FALSE. IF( .NOT.ILAZRO ) THEN - IF( ABS1( A( J, J-1 ) )*( ASCALE*ABS1( A( J+1, - $ J ) ) ).LE.ABS1( A( J, J ) )*( ASCALE*ATOL ) ) + IF( ABS1( H( J, J-1 ) )*( ASCALE*ABS1( H( J+1, + $ J ) ) ).LE.ABS1( H( J, J ) )*( ASCALE*ATOL ) ) $ ILAZR2 = .TRUE. END IF * @@ -459,24 +484,24 @@ * IF( ILAZRO .OR. ILAZR2 ) THEN DO 20 JCH = J, ILAST - 1 - CTEMP = A( JCH, JCH ) - CALL CLARTG( CTEMP, A( JCH+1, JCH ), C, S, - $ A( JCH, JCH ) ) - A( JCH+1, JCH ) = CZERO - CALL CROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA, - $ A( JCH+1, JCH+1 ), LDA, C, S ) - CALL CROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB, - $ B( JCH+1, JCH+1 ), LDB, C, S ) + CTEMP = H( JCH, JCH ) + CALL CLARTG( CTEMP, H( JCH+1, JCH ), C, S, + $ H( JCH, JCH ) ) + H( JCH+1, JCH ) = CZERO + CALL CROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH, + $ H( JCH+1, JCH+1 ), LDH, C, S ) + CALL CROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT, + $ T( JCH+1, JCH+1 ), LDT, C, S ) IF( ILQ ) $ CALL CROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, CONJG( S ) ) IF( ILAZR2 ) - $ A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C + $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C ILAZR2 = .FALSE. * --------------- Begin Timing Code ----------------- OPST = OPST + REAL( 32+40*( ILASTM-JCH )+20*NQ ) * ---------------- End Timing Code ------------------ - IF( ABS1( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN + IF( ABS1( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN IF( JCH+1.GE.ILAST ) THEN GO TO 60 ELSE @@ -484,35 +509,35 @@ GO TO 70 END IF END IF - B( JCH+1, JCH+1 ) = CZERO + T( JCH+1, JCH+1 ) = CZERO 20 CONTINUE GO TO 50 ELSE * -* Only test 2 passed -- chase the zero to B(ILAST,ILAST) -* Then process as in the case B(ILAST,ILAST)=0 +* Only test 2 passed -- chase the zero to T(ILAST,ILAST) +* Then process as in the case T(ILAST,ILAST)=0 * DO 30 JCH = J, ILAST - 1 - CTEMP = B( JCH, JCH+1 ) - CALL CLARTG( CTEMP, B( JCH+1, JCH+1 ), C, S, - $ B( JCH, JCH+1 ) ) - B( JCH+1, JCH+1 ) = CZERO + CTEMP = T( JCH, JCH+1 ) + CALL CLARTG( CTEMP, T( JCH+1, JCH+1 ), C, S, + $ T( JCH, JCH+1 ) ) + T( JCH+1, JCH+1 ) = CZERO IF( JCH.LT.ILASTM-1 ) - $ CALL CROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB, - $ B( JCH+1, JCH+2 ), LDB, C, S ) - CALL CROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA, - $ A( JCH+1, JCH-1 ), LDA, C, S ) + $ CALL CROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT, + $ T( JCH+1, JCH+2 ), LDT, C, S ) + CALL CROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH, + $ H( JCH+1, JCH-1 ), LDH, C, S ) IF( ILQ ) $ CALL CROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, CONJG( S ) ) - CTEMP = A( JCH+1, JCH ) - CALL CLARTG( CTEMP, A( JCH+1, JCH-1 ), C, S, - $ A( JCH+1, JCH ) ) - A( JCH+1, JCH-1 ) = CZERO - CALL CROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1, - $ A( IFRSTM, JCH-1 ), 1, C, S ) - CALL CROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1, - $ B( IFRSTM, JCH-1 ), 1, C, S ) + CTEMP = H( JCH+1, JCH ) + CALL CLARTG( CTEMP, H( JCH+1, JCH-1 ), C, S, + $ H( JCH+1, JCH ) ) + H( JCH+1, JCH-1 ) = CZERO + CALL CROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1, + $ H( IFRSTM, JCH-1 ), 1, C, S ) + CALL CROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1, + $ T( IFRSTM, JCH-1 ), 1, C, S ) IF( ILZ ) $ CALL CROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, $ C, S ) @@ -542,40 +567,40 @@ INFO = 2*N + 1 GO TO 210 * -* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a +* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a * 1x1 block. * 50 CONTINUE - CTEMP = A( ILAST, ILAST ) - CALL CLARTG( CTEMP, A( ILAST, ILAST-1 ), C, S, - $ A( ILAST, ILAST ) ) - A( ILAST, ILAST-1 ) = CZERO - CALL CROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1, - $ A( IFRSTM, ILAST-1 ), 1, C, S ) - CALL CROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1, - $ B( IFRSTM, ILAST-1 ), 1, C, S ) + CTEMP = H( ILAST, ILAST ) + CALL CLARTG( CTEMP, H( ILAST, ILAST-1 ), C, S, + $ H( ILAST, ILAST ) ) + H( ILAST, ILAST-1 ) = CZERO + CALL CROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1, + $ H( IFRSTM, ILAST-1 ), 1, C, S ) + CALL CROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1, + $ T( IFRSTM, ILAST-1 ), 1, C, S ) IF( ILZ ) $ CALL CROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S ) * --------------------- Begin Timing Code ----------------------- OPST = OPST + REAL( 32+40*( ILAST-IFRSTM )+20*NZ ) * ---------------------- End Timing Code ------------------------ * -* A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA +* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA * 60 CONTINUE - ABSB = ABS( B( ILAST, ILAST ) ) + ABSB = ABS( T( ILAST, ILAST ) ) IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = CONJG( B( ILAST, ILAST ) / ABSB ) - B( ILAST, ILAST ) = ABSB + SIGNBC = CONJG( T( ILAST, ILAST ) / ABSB ) + T( ILAST, ILAST ) = ABSB IF( ILSCHR ) THEN - CALL CSCAL( ILAST-IFRSTM, SIGNBC, B( IFRSTM, ILAST ), 1 ) - CALL CSCAL( ILAST+1-IFRSTM, SIGNBC, A( IFRSTM, ILAST ), + CALL CSCAL( ILAST-IFRSTM, SIGNBC, T( IFRSTM, ILAST ), 1 ) + CALL CSCAL( ILAST+1-IFRSTM, SIGNBC, H( IFRSTM, ILAST ), $ 1 ) * ----------------- Begin Timing Code --------------------- OPST = OPST + REAL( 12*( ILAST-IFRSTM ) ) * ------------------ End Timing Code ---------------------- ELSE - A( ILAST, ILAST ) = A( ILAST, ILAST )*SIGNBC + H( ILAST, ILAST ) = H( ILAST, ILAST )*SIGNBC END IF IF( ILZ ) $ CALL CSCAL( N, SIGNBC, Z( 1, ILAST ), 1 ) @@ -583,10 +608,10 @@ OPST = OPST + REAL( 6*NZ+13 ) * -------------------- End Timing Code ----------------------- ELSE - B( ILAST, ILAST ) = CZERO + T( ILAST, ILAST ) = CZERO END IF - ALPHA( ILAST ) = A( ILAST, ILAST ) - BETA( ILAST ) = B( ILAST, ILAST ) + ALPHA( ILAST ) = H( ILAST, ILAST ) + BETA( ILAST ) = T( ILAST, ILAST ) * * Go to next block -- exit if finished. * @@ -619,7 +644,7 @@ * Compute the Shift. * * At this point, IFIRST < ILAST, and the diagonal elements of -* B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in +* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in * magnitude) * IF( ( IITER / 10 )*10.NE.IITER ) THEN @@ -631,26 +656,26 @@ * We factor B as U*D, where U has unit diagonals, and * compute (A*inv(D))*inv(U). * - U12 = ( BSCALE*B( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD22 = ( ASCALE*A( ILAST, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) + U12 = ( BSCALE*T( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD22 = ( ASCALE*H( ILAST, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) ABI22 = AD22 - U12*AD21 * - T = HALF*( AD11+ABI22 ) - RTDISC = SQRT( T**2+AD12*AD21-AD11*AD22 ) - TEMP = REAL( T-ABI22 )*REAL( RTDISC ) + - $ AIMAG( T-ABI22 )*AIMAG( RTDISC ) + T1 = HALF*( AD11+ABI22 ) + RTDISC = SQRT( T1**2+AD12*AD21-AD11*AD22 ) + TEMP = REAL( T1-ABI22 )*REAL( RTDISC ) + + $ AIMAG( T1-ABI22 )*AIMAG( RTDISC ) IF( TEMP.LE.ZERO ) THEN - SHIFT = T + RTDISC + SHIFT = T1 + RTDISC ELSE - SHIFT = T - RTDISC + SHIFT = T1 - RTDISC END IF * * ------------------- Begin Timing Code ---------------------- @@ -661,8 +686,8 @@ * * Exceptional shift. Chosen for no particularly good reason. * - ESHIFT = ESHIFT + CONJG( ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) ) + ESHIFT = ESHIFT + CONJG( ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) ) SHIFT = ESHIFT * * ------------------- Begin Timing Code ---------------------- @@ -675,21 +700,21 @@ * DO 80 J = ILAST - 1, IFIRST + 1, -1 ISTART = J - CTEMP = ASCALE*A( J, J ) - SHIFT*( BSCALE*B( J, J ) ) + CTEMP = ASCALE*H( J, J ) - SHIFT*( BSCALE*T( J, J ) ) TEMP = ABS1( CTEMP ) - TEMP2 = ASCALE*ABS1( A( J+1, J ) ) + TEMP2 = ASCALE*ABS1( H( J+1, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( ABS1( A( J, J-1 ) )*TEMP2.LE.TEMP*ATOL ) + IF( ABS1( H( J, J-1 ) )*TEMP2.LE.TEMP*ATOL ) $ GO TO 90 80 CONTINUE * ISTART = IFIRST - CTEMP = ASCALE*A( IFIRST, IFIRST ) - - $ SHIFT*( BSCALE*B( IFIRST, IFIRST ) ) + CTEMP = ASCALE*H( IFIRST, IFIRST ) - + $ SHIFT*( BSCALE*T( IFIRST, IFIRST ) ) * * --------------------- Begin Timing Code ----------------------- OPST = OPST - REAL( 6 ) @@ -701,7 +726,7 @@ * * Initial Q * - CTEMP2 = ASCALE*A( ISTART+1, ISTART ) + CTEMP2 = ASCALE*H( ISTART+1, ISTART ) * * --------------------- Begin Timing Code ----------------------- OPST = OPST + REAL( 2+( ILAST-ISTART )*18 ) @@ -713,18 +738,18 @@ * DO 150 J = ISTART, ILAST - 1 IF( J.GT.ISTART ) THEN - CTEMP = A( J, J-1 ) - CALL CLARTG( CTEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = CZERO + CTEMP = H( J, J-1 ) + CALL CLARTG( CTEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = CZERO END IF * DO 100 JC = J, ILASTM - CTEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -CONJG( S )*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = CTEMP - CTEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -CONJG( S )*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = CTEMP2 + CTEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -CONJG( S )*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = CTEMP + CTEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -CONJG( S )*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = CTEMP2 100 CONTINUE IF( ILQ ) THEN DO 110 JR = 1, N @@ -734,19 +759,19 @@ 110 CONTINUE END IF * - CTEMP = B( J+1, J+1 ) - CALL CLARTG( CTEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = CZERO + CTEMP = T( J+1, J+1 ) + CALL CLARTG( CTEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = CZERO * DO 120 JR = IFRSTM, MIN( J+2, ILAST ) - CTEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -CONJG( S )*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = CTEMP + CTEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -CONJG( S )*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = CTEMP 120 CONTINUE DO 130 JR = IFRSTM, J - CTEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -CONJG( S )*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = CTEMP + CTEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -CONJG( S )*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = CTEMP 130 CONTINUE IF( ILZ ) THEN DO 140 JR = 1, N @@ -792,18 +817,18 @@ * Set Eigenvalues 1:ILO-1 * DO 200 J = 1, ILO - 1 - ABSB = ABS( B( J, J ) ) + ABSB = ABS( T( J, J ) ) IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = CONJG( B( J, J ) / ABSB ) - B( J, J ) = ABSB + SIGNBC = CONJG( T( J, J ) / ABSB ) + T( J, J ) = ABSB IF( ILSCHR ) THEN - CALL CSCAL( J-1, SIGNBC, B( 1, J ), 1 ) - CALL CSCAL( J, SIGNBC, A( 1, J ), 1 ) + CALL CSCAL( J-1, SIGNBC, T( 1, J ), 1 ) + CALL CSCAL( J, SIGNBC, H( 1, J ), 1 ) * ----------------- Begin Timing Code --------------------- OPST = OPST + REAL( 12*( J-1 ) ) * ------------------ End Timing Code ---------------------- ELSE - A( J, J ) = A( J, J )*SIGNBC + H( J, J ) = H( J, J )*SIGNBC END IF IF( ILZ ) $ CALL CSCAL( N, SIGNBC, Z( 1, J ), 1 ) @@ -811,10 +836,10 @@ OPST = OPST + REAL( 6*NZ+13 ) * -------------------- End Timing Code ----------------------- ELSE - B( J, J ) = CZERO + T( J, J ) = CZERO END IF - ALPHA( J ) = A( J, J ) - BETA( J ) = B( J, J ) + ALPHA( J ) = H( J, J ) + BETA( J ) = T( J, J ) 200 CONTINUE * * Normal Termination diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/ctgevc.f LAPACK/TIMING/EIG/EIGSRC/ctgevc.f --- LAPACK.orig/TIMING/EIG/EIGSRC/ctgevc.f Thu Nov 4 14:28:30 1999 +++ LAPACK/TIMING/EIG/EIGSRC/ctgevc.f Fri May 25 16:20:48 2001 @@ -1,19 +1,19 @@ - SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, + SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO ) * * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 4, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE - INTEGER INFO, LDA, LDB, LDVL, LDVR, M, MM, N + INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) REAL RWORK( * ) - COMPLEX A( LDA, * ), B( LDB, * ), VL( LDVL, * ), + COMPLEX P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * @@ -34,28 +34,30 @@ * Purpose * ======= * -* CTGEVC computes some or all of the right and/or left generalized -* eigenvectors of a pair of complex upper triangular matrices (A,B). -* -* The right generalized eigenvector x and the left generalized -* eigenvector y of (A,B) corresponding to a generalized eigenvalue -* w are defined by: -* -* (A - wB) * x = 0 and y**H * (A - wB) = 0 -* +* CTGEVC computes some or all of the right and/or left eigenvectors of +* a pair of complex matrices (S,P), where S and P are upper triangular. +* Matrix pairs of this type are produced by the generalized Schur +* factorization of a complex matrix pair (A,B): +* +* A = Q*S*Z**H, B = Q*P*Z**H +* +* as computed by CGGHRD + CHGEQZ. +* +* The right eigenvector x and the left eigenvector y of (S,P) +* corresponding to an eigenvalue w are defined by: +* +* S*x = w*P*x, (y**H)*S = w*(y**H)*P, +* * where y**H denotes the conjugate tranpose of y. -* -* If an eigenvalue w is determined by zero diagonal elements of both A -* and B, a unit vector is returned as the corresponding eigenvector. -* -* If all eigenvectors are requested, the routine may either return -* the matrices X and/or Y of right or left eigenvectors of (A,B), or -* the products Z*X and/or Q*Y, where Z and Q are input unitary -* matrices. If (A,B) was obtained from the generalized Schur -* factorization of an original pair of matrices -* (A0,B0) = (Q*A*Z**H,Q*B*Z**H), -* then Z*X and Q*Y are the matrices of right or left eigenvectors of -* A. +* The eigenvalues are not input to this routine, but are computed +* directly from the diagonal elements of S and P. +* +* This routine returns the matrices X and/or Y of right and left +* eigenvectors of (S,P), or the products Z*X and/or Q*Y, +* where Z and Q are input matrices. +* If Q and Z are the unitary factors from the generalized Schur +* factorization of a matrix pair (A,B), then Z*X and Q*Y +* are the matrices of right and left eigenvectors of (A,B). * * Arguments * ========= @@ -67,70 +69,69 @@ * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; -* = 'B': compute all right and/or left eigenvectors, and -* backtransform them using the input matrices supplied -* in VR and/or VL; +* = 'B': compute all right and/or left eigenvectors, +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY='S', SELECT specifies the eigenvectors to be -* computed. -* If HOWMNY='A' or 'B', SELECT is not referenced. -* To select the eigenvector corresponding to the j-th -* eigenvalue, SELECT(j) must be set to .TRUE.. +* 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 matrices A and B. N >= 0. -* -* A (input) COMPLEX array, dimension (LDA,N) -* The upper triangular matrix A. -* -* LDA (input) INTEGER -* The leading dimension of array A. LDA >= max(1,N). +* The order of the matrices S and P. N >= 0. * -* B (input) COMPLEX array, dimension (LDB,N) -* The upper triangular matrix B. B must have real diagonal -* elements. +* S (input) COMPLEX array, dimension (LDS,N) +* The upper triangular matrix S from a generalized Schur +* factorization, as computed by CHGEQZ. +* +* LDS (input) INTEGER +* The leading dimension of array S. LDS >= max(1,N). +* +* P (input) COMPLEX array, dimension (LDP,N) +* The upper triangular matrix P from a generalized Schur +* factorization, as computed by CHGEQZ. P must have real +* diagonal elements. * -* LDB (input) INTEGER -* The leading dimension of array B. LDB >= max(1,N). +* LDP (input) INTEGER +* The leading dimension of array P. LDP >= max(1,N). * * VL (input/output) COMPLEX 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 left Schur vectors returned by CHGEQZ). * On exit, if SIDE = 'L' or 'B', VL contains: -* if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Q*Y; -* if HOWMNY = 'S', the left eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VL, in the same order as their eigenvalues. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of array VL. -* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of array VL. LDVL >= 1, and if +* SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N. * * VR (input/output) COMPLEX 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 Z * of right Schur vectors returned by CHGEQZ). * On exit, if SIDE = 'R' or 'B', VR contains: -* if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Z*X; -* if HOWMNY = 'S', the right eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VR, in the same order as their eigenvalues. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. -* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* The leading dimension of the array VR. LDVR >= 1, and if +* SIDE = 'R' or 'B', LDVR >= N. * * MM (input) INTEGER -* The leading dimension of the array VR. -* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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 @@ -194,7 +195,7 @@ IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. - ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN + ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. @@ -225,9 +226,9 @@ INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN @@ -251,7 +252,7 @@ * ILBBAD = .FALSE. DO 20 J = 1, N - IF( AIMAG( B( J, J ) ).NE.ZERO ) + IF( AIMAG( P( J, J ) ).NE.ZERO ) $ ILBBAD = .TRUE. 20 CONTINUE * @@ -289,19 +290,19 @@ * part of A and B to check for possible overflow in the triangular * solver. * - ANORM = ABS1( A( 1, 1 ) ) - BNORM = ABS1( B( 1, 1 ) ) + ANORM = ABS1( S( 1, 1 ) ) + BNORM = ABS1( P( 1, 1 ) ) RWORK( 1 ) = ZERO RWORK( N+1 ) = ZERO DO 40 J = 2, N RWORK( J ) = ZERO RWORK( N+J ) = ZERO DO 30 I = 1, J - 1 - RWORK( J ) = RWORK( J ) + ABS1( A( I, J ) ) - RWORK( N+J ) = RWORK( N+J ) + ABS1( B( I, J ) ) + RWORK( J ) = RWORK( J ) + ABS1( S( I, J ) ) + RWORK( N+J ) = RWORK( N+J ) + ABS1( P( I, J ) ) 30 CONTINUE - ANORM = MAX( ANORM, RWORK( J )+ABS1( A( J, J ) ) ) - BNORM = MAX( BNORM, RWORK( N+J )+ABS1( B( J, J ) ) ) + ANORM = MAX( ANORM, RWORK( J )+ABS1( S( J, J ) ) ) + BNORM = MAX( BNORM, RWORK( N+J )+ABS1( P( J, J ) ) ) 40 CONTINUE * ASCALE = ONE / MAX( ANORM, SAFMIN ) @@ -326,8 +327,8 @@ IF( ILCOMP ) THEN IEIG = IEIG + 1 * - IF( ABS1( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( REAL( B( JE, JE ) ) ).LE.SAFMIN ) THEN + IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( REAL( P( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * @@ -343,10 +344,10 @@ * H * y ( a A - b B ) = 0 * - TEMP = ONE / MAX( ABS1( A( JE, JE ) )*ASCALE, - $ ABS( REAL( B( JE, JE ) ) )*BSCALE, SAFMIN ) - SALPHA = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*REAL( B( JE, JE ) ) )*BSCALE + TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, + $ ABS( REAL( P( JE, JE ) ) )*BSCALE, SAFMIN ) + SALPHA = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*REAL( P( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * @@ -403,7 +404,7 @@ * * Compute * j-1 -* SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) +* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * (Scale if necessary) * @@ -422,16 +423,16 @@ SUMB = CZERO * DO 80 JR = JE, J - 1 - SUMA = SUMA + CONJG( A( JR, J ) )*WORK( JR ) - SUMB = SUMB + CONJG( B( JR, J ) )*WORK( JR ) + SUMA = SUMA + CONJG( S( JR, J ) )*WORK( JR ) + SUMB = SUMB + CONJG( P( JR, J ) )*WORK( JR ) 80 CONTINUE SUM = ACOEFF*SUMA - CONJG( BCOEFF )*SUMB * -* Form x(j) = - SUM / conjg( a*A(j,j) - b*B(j,j) ) +* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) * * with scaling and perturbation of the denominator * - D = CONJG( ACOEFF*A( J, J )-BCOEFF*B( J, J ) ) + D = CONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) ) IF( ABS1( D ).LE.DMIN ) $ D = CMPLX( DMIN ) * @@ -511,8 +512,8 @@ IF( ILCOMP ) THEN IEIG = IEIG - 1 * - IF( ABS1( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( REAL( B( JE, JE ) ) ).LE.SAFMIN ) THEN + IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( REAL( P( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * @@ -528,10 +529,10 @@ * * ( a A - b B ) x = 0 * - TEMP = ONE / MAX( ABS1( A( JE, JE ) )*ASCALE, - $ ABS( REAL( B( JE, JE ) ) )*BSCALE, SAFMIN ) - SALPHA = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*REAL( B( JE, JE ) ) )*BSCALE + TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, + $ ABS( REAL( P( JE, JE ) ) )*BSCALE, SAFMIN ) + SALPHA = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*REAL( P( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * @@ -584,7 +585,7 @@ * WORK(j+1:JE) contains x * DO 170 JR = 1, JE - 1 - WORK( JR ) = ACOEFF*A( JR, JE ) - BCOEFF*B( JR, JE ) + WORK( JR ) = ACOEFF*S( JR, JE ) - BCOEFF*P( JR, JE ) 170 CONTINUE WORK( JE ) = CONE * @@ -593,7 +594,7 @@ * Form x(j) := - w(j) / d * with scaling and perturbation of the denominator * - D = ACOEFF*A( J, J ) - BCOEFF*B( J, J ) + D = ACOEFF*S( J, J ) - BCOEFF*P( J, J ) IF( ABS1( D ).LE.DMIN ) $ D = CMPLX( DMIN ) * @@ -615,7 +616,7 @@ * IF( J.GT.1 ) THEN * -* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling +* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( ABS1( WORK( J ) ).GT.ONE ) THEN TEMP = ONE / ABS1( WORK( J ) ) @@ -635,8 +636,8 @@ CA = ACOEFF*WORK( J ) CB = BCOEFF*WORK( J ) DO 200 JR = 1, J - 1 - WORK( JR ) = WORK( JR ) + CA*A( JR, J ) - - $ CB*B( JR, J ) + WORK( JR ) = WORK( JR ) + CA*S( JR, J ) - + $ CB*P( JR, J ) 200 CONTINUE END IF 210 CONTINUE diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/ctrevc.f LAPACK/TIMING/EIG/EIGSRC/ctrevc.f --- LAPACK.orig/TIMING/EIG/EIGSRC/ctrevc.f Thu Nov 4 14:28:30 1999 +++ LAPACK/TIMING/EIG/EIGSRC/ctrevc.f Fri May 25 16:21:06 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 7, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -31,20 +31,23 @@ * * CTREVC 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 CHSEQR. +* * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: -* -* T*x = w*x, y'*T = w*y' -* -* where y' denotes the conjugate transpose of the vector y. -* -* If all eigenvectors are requested, the routine may either return the -* matrices X and/or Y of right or left eigenvectors of T, or the -* products Q*X and/or Q*Y, where Q is an input unitary -* matrix. If T was obtained from the Schur factorization of an -* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of -* right or left eigenvectors of A. +* +* T*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 * ========= @@ -57,17 +60,17 @@ * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, -* and backtransform them using the input matrices -* supplied in VR and/or VL; +* backtransformed using the matrices supplied in +* VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, -* specified by the logical array SELECT. +* as indicated by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. -* If HOWMNY = 'A' or 'B', SELECT is not referenced. -* To select the eigenvector corresponding to the j-th -* eigenvalue, SELECT(j) must be set to .TRUE.. +* 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. @@ -85,19 +88,16 @@ * Schur vectors returned by CHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; -* VL is lower triangular. The i-th column -* VL(i) of VL is the eigenvector corresponding -* to T(i,i). * 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. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of the array VL. LDVL >= max(1,N) if -* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of the array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) COMPLEX array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must @@ -105,19 +105,16 @@ * Schur vectors returned by CHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; -* VR is upper triangular. The i-th column -* VR(i) of VR is the eigenvector corresponding -* to T(i,i). * 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. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. LDVR >= max(1,N) if -* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/dbdsqr.f LAPACK/TIMING/EIG/EIGSRC/dbdsqr.f --- LAPACK.orig/TIMING/EIG/EIGSRC/dbdsqr.f Thu Nov 4 14:28:31 1999 +++ LAPACK/TIMING/EIG/EIGSRC/dbdsqr.f Fri May 25 16:19:53 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. CHARACTER UPLO @@ -26,14 +26,26 @@ * Purpose * ======= * -* DBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. +* DBDSQR 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**T +* +* 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**T*VT instead of +* P**T, for given real input matrices U and VT. When U and VT are the +* orthogonal matrices that reduce a general matrix A to bidiagonal +* form: A = U*B*VT, as computed by DGEBRD, then * -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given real input matrices U, VT, and C. +* A = (U*Q) * S * (P**T*VT) +* +* is the SVD of A. Optionally, the subroutine may also compute Q**T*C +* for a given real input matrix C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, @@ -69,18 +81,17 @@ * order. * * E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E +* 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. E(N) is used for workspace. * * VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. +* On exit, VT is overwritten by P**T * VT. +* Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. @@ -89,21 +100,22 @@ * U (input/output) DOUBLE PRECISION array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. -* U is not referenced if NRU = 0. +* Not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. -* On exit, C is overwritten by Q' * C. -* C is not referenced if NCC = 0. +* On exit, C is overwritten by Q**T * 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. * -* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) +* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise * * INFO (output) INTEGER * = 0: successful exit diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/dgghrd.f LAPACK/TIMING/EIG/EIGSRC/dgghrd.f --- LAPACK.orig/TIMING/EIG/EIGSRC/dgghrd.f Thu Nov 4 14:28:31 1999 +++ LAPACK/TIMING/EIG/EIGSRC/dgghrd.f Fri May 25 16:20:14 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ @@ -33,16 +33,32 @@ * * DGGHRD reduces a pair of real matrices (A,B) to generalized upper * Hessenberg form using orthogonal transformations, where A is a -* general matrix and B is upper triangular: Q' * A * Z = H and -* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, -* and Q and Z are orthogonal, and ' means transpose. +* general matrix and B is upper triangular. The form of the +* generalized eigenvalue problem is +* A*x = lambda*B*x, +* and B is typically made upper triangular by computing its QR +* factorization and moving the orthogonal matrix Q to the left side +* of the equation. +* +* This subroutine simultaneously reduces A to a Hessenberg matrix H: +* Q**T*A*Z = H +* and transforms B to another upper triangular matrix T: +* Q**T*B*Z = T +* in order to reduce the problem to its standard form +* H*y = lambda*T*y +* where y = Z**T*x. * * The orthogonal matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be * postmultiplied into input matrices Q1 and Z1, so that * -* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' -* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' +* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T +* +* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T +* +* If Q1 is the orthogonal matrix from the QR factorization of B in the +* original equation A*x = lambda*B*x, then DGGHRD reduces the original +* problem to generalized Hessenberg form. * * Arguments * ========= @@ -66,10 +82,11 @@ * * ILO (input) INTEGER * IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally set -* by a previous call to DGGBAL; otherwise they should be set -* to 1 and N respectively. +* ILO and IHI mark the rows and columns of A which are to be +* reduced. 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 SGGBAL; otherwise they +* should be set to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) @@ -83,33 +100,28 @@ * * B (input/output) DOUBLE PRECISION array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. -* On exit, the upper triangular matrix T = Q' B Z. The +* On exit, the upper triangular matrix T = Q**T B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) -* If COMPQ='N': Q is not referenced. -* If COMPQ='I': on entry, Q need not be set, and on exit it -* contains the orthogonal matrix Q, where Q' -* is the product of the Givens transformations -* which are applied to A and B on the left. -* If COMPQ='V': on entry, Q must contain an orthogonal matrix -* Q1, and on exit this is overwritten by Q1*Q. +* On entry, if COMPQ = 'V', the orthogonal matrix Q1, +* typically from the QR factorization of B. +* On exit, if COMPQ='I', the orthogonal matrix Q, and if +* COMPQ = 'V', the product Q1*Q. +* Not referenced if COMPQ='N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) -* If COMPZ='N': Z is not referenced. -* If COMPZ='I': on entry, Z need not be set, and on exit it -* contains the orthogonal matrix Z, which is -* the product of the Givens transformations -* which are applied to A and B on the right. -* If COMPZ='V': on entry, Z must contain an orthogonal matrix -* Z1, and on exit this is overwritten by Z1*Z. +* On entry, if COMPZ = 'V', the orthogonal matrix Z1. +* On exit, if COMPZ='I', the orthogonal matrix Z, and if +* COMPZ = 'V', the product Z1*Z. +* Not referenced if COMPZ='N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/dhgeqz.f LAPACK/TIMING/EIG/EIGSRC/dhgeqz.f --- LAPACK.orig/TIMING/EIG/EIGSRC/dhgeqz.f Thu Nov 4 14:28:33 1999 +++ LAPACK/TIMING/EIG/EIGSRC/dhgeqz.f Fri May 25 16:20:32 2001 @@ -1,20 +1,20 @@ - SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, + SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 3, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), - $ B( LDB, * ), BETA( * ), Q( LDQ, * ), WORK( * ), - $ Z( LDZ, * ) + DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), + $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), + $ WORK( * ), Z( LDZ, * ) * .. * ---------------------- Begin Timing Code ------------------------- * Common block to return operation count and iteration count @@ -32,37 +32,56 @@ * Purpose * ======= * -* DHGEQZ implements a single-/double-shift version of the QZ method for -* finding the generalized eigenvalues -* -* w(j)=(ALPHAR(j) + i*ALPHAI(j))/BETAR(j) of the equation -* -* det( A - w(i) B ) = 0 -* -* In addition, the pair A,B may be reduced to generalized Schur form: -* B is upper triangular, and A is block upper triangular, where the -* diagonal blocks are either 1-by-1 or 2-by-2, the 2-by-2 blocks having -* complex generalized eigenvalues (see the description of the argument -* JOB.) -* -* If JOB='S', then the pair (A,B) is simultaneously reduced to Schur -* form by applying one orthogonal tranformation (usually called Q) on -* the left and another (usually called Z) on the right. The 2-by-2 -* upper-triangular diagonal blocks of B corresponding to 2-by-2 blocks -* of A will be reduced to positive diagonal matrices. (I.e., -* if A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) and -* B(j+1,j+1) will be positive.) -* -* If JOB='E', then at each iteration, the same transformations -* are computed, but they are only applied to those parts of A and B -* which are needed to compute ALPHAR, ALPHAI, and BETAR. -* -* If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the orthogonal -* transformations used to reduce (A,B) are accumulated into the arrays -* Q and Z s.t.: -* -* Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* -* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* +* DHGEQZ computes the eigenvalues of a real matrix pair (H,T), +* where H is an upper Hessenberg matrix and T is upper triangular, +* using the double-shift QZ method. +* Matrix pairs of this type are produced by the reduction to +* generalized upper Hessenberg form of a real matrix pair (A,B): +* +* A = Q1*H*Z1**T, B = Q1*T*Z1**T, +* +* as computed by DGGHRD. +* +* If JOB='S', then the Hessenberg-triangular pair (H,T) is +* also reduced to generalized Schur form, +* +* H = Q*S*Z**T, T = Q*P*Z**T, +* +* where Q and Z are orthogonal matrices, P is an upper triangular +* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 +* diagonal blocks. +* +* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair +* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of +* eigenvalues. +* +* Additionally, the 2-by-2 upper triangular diagonal blocks of P +* corresponding to 2-by-2 blocks of S are reduced to positive diagonal +* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, +* P(j,j) > 0, and P(j+1,j+1) > 0. +* +* Optionally, the orthogonal matrix Q from the generalized Schur +* factorization may be postmultiplied into an input matrix Q1, and the +* orthogonal matrix Z may be postmultiplied into an input matrix Z1. +* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced +* the matrix pair (A,B) to generalized upper Hessenberg form, then the +* output matrices Q1*Q and Z1*Z are the orthogonal factors from the +* generalized Schur factorization of (A,B): +* +* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. +* +* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, +* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is +* complex and beta real. +* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the +* generalized nonsymmetric eigenvalue problem (GNEP) +* A*x = lambda*B*x +* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the +* alternate form of the GNEP +* mu*A*y = B*y. +* Real eigenvalues can be read directly from the generalized Schur +* form: +* alpha = S(i,i), beta = P(i,i). * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), @@ -72,114 +91,98 @@ * ========= * * JOB (input) CHARACTER*1 -* = 'E': compute only ALPHAR, ALPHAI, and BETA. A and B will -* not necessarily be put into generalized Schur form. -* = 'S': put A and B into generalized Schur form, as well -* as computing ALPHAR, ALPHAI, and BETA. +* = 'E': Compute eigenvalues only; +* = 'S': Compute eigenvalues and the Schur form. * * COMPQ (input) CHARACTER*1 -* = 'N': do not modify Q. -* = 'V': multiply the array Q on the right by the transpose of -* the orthogonal tranformation that is applied to the -* left side of A and B to reduce them to Schur form. -* = 'I': like COMPQ='V', except that Q will be initialized to -* the identity first. +* = 'N': Left Schur vectors (Q) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Q +* of left Schur vectors of (H,T) is returned; +* = 'V': Q must contain an orthogonal matrix Q1 on entry and +* the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 -* = 'N': do not modify Z. -* = 'V': multiply the array Z on the right by the orthogonal -* tranformation that is applied to the right side of -* A and B to reduce them to Schur form. -* = 'I': like COMPZ='V', except that Z will be initialized to -* the identity first. +* = 'N': Right Schur vectors (Z) are not computed; +* = 'I': Z is initialized to the unit matrix and the matrix Z +* of right Schur vectors of (H,T) is returned; +* = 'V': Z must contain an orthogonal matrix Z1 on entry and +* the product Z1*Z is returned. * * N (input) INTEGER -* The order of the matrices A, B, Q, and Z. N >= 0. +* The order of the matrices H, T, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) -* On entry, the N-by-N upper Hessenberg matrix A. Elements -* below the subdiagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to generalized Schur form. -* If JOB='E', then on exit A will have been destroyed. -* The diagonal blocks will be correct, but the off-diagonal -* portion will be meaningless. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max( 1, N ). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) -* On entry, the N-by-N upper triangular matrix B. Elements -* below the diagonal must be zero. 2-by-2 blocks in B -* corresponding to 2-by-2 blocks in A will be reduced to -* positive diagonal form. (I.e., if A(j+1,j) is non-zero, -* then B(j+1,j)=B(j,j+1)=0 and B(j,j) and B(j+1,j+1) will be -* positive.) -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to Schur form. -* If JOB='E', then on exit B will have been destroyed. -* Elements corresponding to diagonal blocks of A will be -* correct, but the off-diagonal portion will be meaningless. +* ILO and IHI mark the rows and columns of H which are in +* Hessenberg form. It is assumed that A is already upper +* triangular in rows and columns 1:ILO-1 and IHI+1:N. +* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. +* +* H (input/output) DOUBLE PRECISION array, dimension (LDH, N) +* On entry, the N-by-N upper Hessenberg matrix H. +* On exit, if JOB = 'S', H contains the upper quasi-triangular +* matrix S from the generalized Schur factorization; +* 2-by-2 diagonal blocks (corresponding to complex conjugate +* pairs of eigenvalues) are returned in standard form, with +* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. +* If JOB = 'E', the diagonal blocks of H match those of S, but +* the rest of H is unspecified. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH >= max( 1, N ). +* +* T (input/output) DOUBLE PRECISION array, dimension (LDT, N) +* On entry, the N-by-N upper triangular matrix T. +* On exit, if JOB = 'S', T contains the upper triangular +* matrix P from the generalized Schur factorization; +* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S +* are reduced to positive diagonal form, i.e., if H(j+1,j) is +* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and +* T(j+1,j+1) > 0. +* If JOB = 'E', the diagonal blocks of T match those of P, but +* the rest of T is unspecified. * -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max( 1, N ). +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max( 1, N ). * * ALPHAR (output) DOUBLE PRECISION array, dimension (N) -* ALPHAR(1:N) will be set to real parts of the diagonal -* elements of A that would result from reducing A and B to -* Schur form and then further reducing them both to triangular -* form using unitary transformations s.t. the diagonal of B -* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=A(j,j). -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. +* The real parts of each scalar alpha defining an eigenvalue +* of GNEP. * * ALPHAI (output) DOUBLE PRECISION array, dimension (N) -* ALPHAI(1:N) will be set to imaginary parts of the diagonal -* elements of A that would result from reducing A and B to -* Schur form and then further reducing them both to triangular -* form using unitary transformations s.t. the diagonal of B -* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=0. -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. +* The imaginary parts of each scalar alpha defining an +* eigenvalue of GNEP. +* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if +* positive, then the j-th and (j+1)-st eigenvalues are a +* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). * * BETA (output) DOUBLE PRECISION array, dimension (N) -* BETA(1:N) will be set to the (real) diagonal elements of B -* that would result from reducing A and B to Schur form and -* then further reducing them both to triangular form using -* unitary transformations s.t. the diagonal of B was -* non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then BETA(j)=B(j,j). -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. -* (Note that BETA(1:N) will always be non-negative, and no -* BETAI is necessary.) +* The scalars beta that define the eigenvalues of GNEP. +* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and +* beta = BETA(j) represent the j-th eigenvalue of the matrix +* pair (A,B), in one of the forms lambda = alpha/beta or +* mu = beta/alpha. Since either lambda or mu may overflow, +* they should not, in general, be computed. * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) -* If COMPQ='N', then Q will not be referenced. -* If COMPQ='V' or 'I', then the transpose of the orthogonal -* transformations which are applied to A and B on the left -* will be applied to the array Q on the right. +* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur +* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix +* of left Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) -* If COMPZ='N', then Z will not be referenced. -* If COMPZ='V' or 'I', then the orthogonal transformations -* which are applied to A and B on the right will be applied -* to the array Z on the right. +* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of +* right Schur vectors of (H,T), and if COMPZ = 'V', the +* orthogonal matrix of right Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. @@ -199,13 +202,12 @@ * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value -* = 1,...,N: the QZ iteration did not converge. (A,B) is not +* = 1,...,N: the QZ iteration did not converge. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO+1,...,N should be correct. -* = N+1,...,2*N: the shift calculation failed. (A,B) is not +* = N+1,...,2*N: the shift calculation failed. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO-N+1,...,N should be correct. -* > 2*N: various "impossible" errors. * * Further Details * =============== @@ -237,7 +239,7 @@ $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ CQ, CR, CZ, ESHIFT, OPST, S, S1, S1INV, S2, $ SAFMAX, SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, - $ SZR, T, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, + $ SZR, T1, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, $ U12, U12L, U2, ULP, VS, W11, W12, W21, W22, $ WABS, WI, WR, WR2 * .. @@ -319,9 +321,9 @@ INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 - ELSE IF( LDA.LT.N ) THEN + ELSE IF( LDH.LT.N ) THEN INFO = -8 - ELSE IF( LDB.LT.N ) THEN + ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -15 @@ -360,8 +362,8 @@ SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) - ANORM = DLANHS( 'F', IN, A( ILO, ILO ), LDA, WORK ) - BNORM = DLANHS( 'F', IN, B( ILO, ILO ), LDB, WORK ) + ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) + BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) @@ -370,15 +372,15 @@ * Set Eigenvalues IHI+1:N * DO 30 J = IHI + 1, N - IF( B( J, J ).LT.ZERO ) THEN + IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 10 JR = 1, J - A( JR, J ) = -A( JR, J ) - B( JR, J ) = -B( JR, J ) + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) 10 CONTINUE ELSE - A( J, J ) = -A( J, J ) - B( J, J ) = -B( J, J ) + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 20 JR = 1, N @@ -386,9 +388,9 @@ 20 CONTINUE END IF END IF - ALPHAR( J ) = A( J, J ) + ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO - BETA( J ) = B( J, J ) + BETA( J ) = T( J, J ) 30 CONTINUE * * ---------------------- Begin Timing Code ------------------------- @@ -435,8 +437,8 @@ * Split the matrix if possible. * * Two tests: -* 1: A(j,j-1)=0 or j=ILO -* 2: B(j,j)=0 +* 1: H(j,j-1)=0 or j=ILO +* 2: T(j,j)=0 * IF( ILAST.EQ.ILO ) THEN * @@ -444,14 +446,14 @@ * GO TO 80 ELSE - IF( ABS( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN - A( ILAST, ILAST-1 ) = ZERO + IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = ZERO GO TO 80 END IF END IF * - IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN - B( ILAST, ILAST ) = ZERO + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = ZERO GO TO 70 END IF * @@ -459,36 +461,36 @@ * DO 60 J = ILAST - 1, ILO, -1 * -* Test 1: for A(j,j-1)=0 or j=ILO +* Test 1: for H(j,j-1)=0 or j=ILO * IF( J.EQ.ILO ) THEN ILAZRO = .TRUE. ELSE - IF( ABS( A( J, J-1 ) ).LE.ATOL ) THEN - A( J, J-1 ) = ZERO + IF( ABS( H( J, J-1 ) ).LE.ATOL ) THEN + H( J, J-1 ) = ZERO ILAZRO = .TRUE. ELSE ILAZRO = .FALSE. END IF END IF * -* Test 2: for B(j,j)=0 +* Test 2: for T(j,j)=0 * - IF( ABS( B( J, J ) ).LT.BTOL ) THEN - B( J, J ) = ZERO + IF( ABS( T( J, J ) ).LT.BTOL ) THEN + T( J, J ) = ZERO * * Test 1a: Check for 2 consecutive small subdiagonals in A * ILAZR2 = .FALSE. IF( .NOT.ILAZRO ) THEN - TEMP = ABS( A( J, J-1 ) ) - TEMP2 = ABS( A( J, J ) ) + TEMP = ABS( H( J, J-1 ) ) + TEMP2 = ABS( H( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( TEMP*( ASCALE*ABS( A( J+1, J ) ) ).LE.TEMP2* + IF( TEMP*( ASCALE*ABS( H( J+1, J ) ) ).LE.TEMP2* $ ( ASCALE*ATOL ) )ILAZR2 = .TRUE. END IF * @@ -500,26 +502,26 @@ * IF( ILAZRO .OR. ILAZR2 ) THEN DO 40 JCH = J, ILAST - 1 - TEMP = A( JCH, JCH ) - CALL DLARTG( TEMP, A( JCH+1, JCH ), C, S, - $ A( JCH, JCH ) ) - A( JCH+1, JCH ) = ZERO - CALL DROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA, - $ A( JCH+1, JCH+1 ), LDA, C, S ) - CALL DROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB, - $ B( JCH+1, JCH+1 ), LDB, C, S ) + TEMP = H( JCH, JCH ) + CALL DLARTG( TEMP, H( JCH+1, JCH ), C, S, + $ H( JCH, JCH ) ) + H( JCH+1, JCH ) = ZERO + CALL DROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH, + $ H( JCH+1, JCH+1 ), LDH, C, S ) + CALL DROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT, + $ T( JCH+1, JCH+1 ), LDT, C, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) IF( ILAZR2 ) - $ A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C + $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C ILAZR2 = .FALSE. * * --------------- Begin Timing Code ----------------- OPST = OPST + DBLE( 7+12*( ILASTM-JCH )+6*NQ ) * ---------------- End Timing Code ------------------ * - IF( ABS( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN + IF( ABS( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN IF( JCH+1.GE.ILAST ) THEN GO TO 80 ELSE @@ -527,35 +529,35 @@ GO TO 110 END IF END IF - B( JCH+1, JCH+1 ) = ZERO + T( JCH+1, JCH+1 ) = ZERO 40 CONTINUE GO TO 70 ELSE * -* Only test 2 passed -- chase the zero to B(ILAST,ILAST) -* Then process as in the case B(ILAST,ILAST)=0 +* Only test 2 passed -- chase the zero to T(ILAST,ILAST) +* Then process as in the case T(ILAST,ILAST)=0 * DO 50 JCH = J, ILAST - 1 - TEMP = B( JCH, JCH+1 ) - CALL DLARTG( TEMP, B( JCH+1, JCH+1 ), C, S, - $ B( JCH, JCH+1 ) ) - B( JCH+1, JCH+1 ) = ZERO + TEMP = T( JCH, JCH+1 ) + CALL DLARTG( TEMP, T( JCH+1, JCH+1 ), C, S, + $ T( JCH, JCH+1 ) ) + T( JCH+1, JCH+1 ) = ZERO IF( JCH.LT.ILASTM-1 ) - $ CALL DROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB, - $ B( JCH+1, JCH+2 ), LDB, C, S ) - CALL DROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA, - $ A( JCH+1, JCH-1 ), LDA, C, S ) + $ CALL DROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT, + $ T( JCH+1, JCH+2 ), LDT, C, S ) + CALL DROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH, + $ H( JCH+1, JCH-1 ), LDH, C, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) - TEMP = A( JCH+1, JCH ) - CALL DLARTG( TEMP, A( JCH+1, JCH-1 ), C, S, - $ A( JCH+1, JCH ) ) - A( JCH+1, JCH-1 ) = ZERO - CALL DROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1, - $ A( IFRSTM, JCH-1 ), 1, C, S ) - CALL DROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1, - $ B( IFRSTM, JCH-1 ), 1, C, S ) + TEMP = H( JCH+1, JCH ) + CALL DLARTG( TEMP, H( JCH+1, JCH-1 ), C, S, + $ H( JCH+1, JCH ) ) + H( JCH+1, JCH-1 ) = ZERO + CALL DROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1, + $ H( IFRSTM, JCH-1 ), 1, C, S ) + CALL DROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1, + $ T( IFRSTM, JCH-1 ), 1, C, S ) IF( ILZ ) $ CALL DROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, $ C, S ) @@ -585,18 +587,18 @@ INFO = N + 1 GO TO 420 * -* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a +* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a * 1x1 block. * 70 CONTINUE - TEMP = A( ILAST, ILAST ) - CALL DLARTG( TEMP, A( ILAST, ILAST-1 ), C, S, - $ A( ILAST, ILAST ) ) - A( ILAST, ILAST-1 ) = ZERO - CALL DROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1, - $ A( IFRSTM, ILAST-1 ), 1, C, S ) - CALL DROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1, - $ B( IFRSTM, ILAST-1 ), 1, C, S ) + TEMP = H( ILAST, ILAST ) + CALL DLARTG( TEMP, H( ILAST, ILAST-1 ), C, S, + $ H( ILAST, ILAST ) ) + H( ILAST, ILAST-1 ) = ZERO + CALL DROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1, + $ H( IFRSTM, ILAST-1 ), 1, C, S ) + CALL DROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1, + $ T( IFRSTM, ILAST-1 ), 1, C, S ) IF( ILZ ) $ CALL DROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S ) * @@ -605,19 +607,19 @@ * ---------------------- End Timing Code ------------------------ * * -* A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, +* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, * and BETA * 80 CONTINUE - IF( B( ILAST, ILAST ).LT.ZERO ) THEN + IF( T( ILAST, ILAST ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 90 J = IFRSTM, ILAST - A( J, ILAST ) = -A( J, ILAST ) - B( J, ILAST ) = -B( J, ILAST ) + H( J, ILAST ) = -H( J, ILAST ) + T( J, ILAST ) = -T( J, ILAST ) 90 CONTINUE ELSE - A( ILAST, ILAST ) = -A( ILAST, ILAST ) - B( ILAST, ILAST ) = -B( ILAST, ILAST ) + H( ILAST, ILAST ) = -H( ILAST, ILAST ) + T( ILAST, ILAST ) = -T( ILAST, ILAST ) END IF IF( ILZ ) THEN DO 100 J = 1, N @@ -625,9 +627,9 @@ 100 CONTINUE END IF END IF - ALPHAR( ILAST ) = A( ILAST, ILAST ) + ALPHAR( ILAST ) = H( ILAST, ILAST ) ALPHAI( ILAST ) = ZERO - BETA( ILAST ) = B( ILAST, ILAST ) + BETA( ILAST ) = T( ILAST, ILAST ) * * Go to next block -- exit if finished. * @@ -660,7 +662,7 @@ * Compute single shifts. * * At this point, IFIRST < ILAST, and the diagonal elements of -* B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in +* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in * magnitude) * IF( ( IITER / 10 )*10.EQ.IITER ) THEN @@ -668,10 +670,10 @@ * Exceptional shift. Chosen for no particularly good reason. * (Single shift only.) * - IF( ( DBLE( MAXIT )*SAFMIN )*ABS( A( ILAST-1, ILAST ) ).LT. - $ ABS( B( ILAST-1, ILAST-1 ) ) ) THEN - ESHIFT = ESHIFT + A( ILAST-1, ILAST ) / - $ B( ILAST-1, ILAST-1 ) + IF( ( DBLE( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT. + $ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN + ESHIFT = ESHIFT + H( ILAST-1, ILAST ) / + $ T( ILAST-1, ILAST-1 ) ELSE ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) ) END IF @@ -688,8 +690,8 @@ * bottom-right 2x2 block of A and B. The first eigenvalue * returned by DLAG2 is the Wilkinson shift (AEP p.512), * - CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA, - $ B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, + CALL DLAG2( H( ILAST-1, ILAST-1 ), LDH, + $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ S2, WR, WR2, WI ) * TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) ) @@ -721,14 +723,14 @@ * DO 120 J = ILAST - 1, IFIRST + 1, -1 ISTART = J - TEMP = ABS( S1*A( J, J-1 ) ) - TEMP2 = ABS( S1*A( J, J )-WR*B( J, J ) ) + TEMP = ABS( S1*H( J, J-1 ) ) + TEMP2 = ABS( S1*H( J, J )-WR*T( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( ABS( ( ASCALE*A( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* + IF( ABS( ( ASCALE*H( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* $ TEMP2 )GO TO 130 120 CONTINUE * @@ -739,26 +741,26 @@ * * Initial Q * - TEMP = S1*A( ISTART, ISTART ) - WR*B( ISTART, ISTART ) - TEMP2 = S1*A( ISTART+1, ISTART ) + TEMP = S1*H( ISTART, ISTART ) - WR*T( ISTART, ISTART ) + TEMP2 = S1*H( ISTART+1, ISTART ) CALL DLARTG( TEMP, TEMP2, C, S, TEMPR ) * * Sweep * DO 190 J = ISTART, ILAST - 1 IF( J.GT.ISTART ) THEN - TEMP = A( J, J-1 ) - CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = ZERO + TEMP = H( J, J-1 ) + CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO END IF * DO 140 JC = J, ILASTM - TEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = TEMP - TEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = TEMP2 + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 140 CONTINUE IF( ILQ ) THEN DO 150 JR = 1, N @@ -768,19 +770,19 @@ 150 CONTINUE END IF * - TEMP = B( J+1, J+1 ) - CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = ZERO + TEMP = T( J+1, J+1 ) + CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO * DO 160 JR = IFRSTM, MIN( J+2, ILAST ) - TEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = TEMP + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP 160 CONTINUE DO 170 JR = IFRSTM, J - TEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = TEMP + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP 170 CONTINUE IF( ILZ ) THEN DO 180 JR = 1, N @@ -816,8 +818,8 @@ * B = ( ) with B11 non-negative. * ( 0 B22 ) * - CALL DLASV2( B( ILAST-1, ILAST-1 ), B( ILAST-1, ILAST ), - $ B( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) + CALL DLASV2( T( ILAST-1, ILAST-1 ), T( ILAST-1, ILAST ), + $ T( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) * IF( B11.LT.ZERO ) THEN CR = -CR @@ -826,17 +828,17 @@ B22 = -B22 END IF * - CALL DROT( ILASTM+1-IFIRST, A( ILAST-1, ILAST-1 ), LDA, - $ A( ILAST, ILAST-1 ), LDA, CL, SL ) - CALL DROT( ILAST+1-IFRSTM, A( IFRSTM, ILAST-1 ), 1, - $ A( IFRSTM, ILAST ), 1, CR, SR ) + CALL DROT( ILASTM+1-IFIRST, H( ILAST-1, ILAST-1 ), LDH, + $ H( ILAST, ILAST-1 ), LDH, CL, SL ) + CALL DROT( ILAST+1-IFRSTM, H( IFRSTM, ILAST-1 ), 1, + $ H( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILAST.LT.ILASTM ) - $ CALL DROT( ILASTM-ILAST, B( ILAST-1, ILAST+1 ), LDB, - $ B( ILAST, ILAST+1 ), LDA, CL, SL ) + $ CALL DROT( ILASTM-ILAST, T( ILAST-1, ILAST+1 ), LDT, + $ T( ILAST, ILAST+1 ), LDH, CL, SL ) IF( IFRSTM.LT.ILAST-1 ) - $ CALL DROT( IFIRST-IFRSTM, B( IFRSTM, ILAST-1 ), 1, - $ B( IFRSTM, ILAST ), 1, CR, SR ) + $ CALL DROT( IFIRST-IFRSTM, T( IFRSTM, ILAST-1 ), 1, + $ T( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILQ ) $ CALL DROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL, @@ -845,17 +847,17 @@ $ CALL DROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR, $ SR ) * - B( ILAST-1, ILAST-1 ) = B11 - B( ILAST-1, ILAST ) = ZERO - B( ILAST, ILAST-1 ) = ZERO - B( ILAST, ILAST ) = B22 + T( ILAST-1, ILAST-1 ) = B11 + T( ILAST-1, ILAST ) = ZERO + T( ILAST, ILAST-1 ) = ZERO + T( ILAST, ILAST ) = B22 * * If B22 is negative, negate column ILAST * IF( B22.LT.ZERO ) THEN DO 210 J = IFRSTM, ILAST - A( J, ILAST ) = -A( J, ILAST ) - B( J, ILAST ) = -B( J, ILAST ) + H( J, ILAST ) = -H( J, ILAST ) + T( J, ILAST ) = -T( J, ILAST ) 210 CONTINUE * IF( ILZ ) THEN @@ -869,8 +871,8 @@ * * Recompute shift * - CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA, - $ B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, + CALL DLAG2( H( ILAST-1, ILAST-1 ), LDH, + $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ TEMP, WR, TEMP2, WI ) * * ------------------- Begin Timing Code ---------------------- @@ -887,10 +889,10 @@ * * Do EISPACK (QZVAL) computation of alpha and beta * - A11 = A( ILAST-1, ILAST-1 ) - A21 = A( ILAST, ILAST-1 ) - A12 = A( ILAST-1, ILAST ) - A22 = A( ILAST, ILAST ) + A11 = H( ILAST-1, ILAST-1 ) + A21 = H( ILAST, ILAST-1 ) + A12 = H( ILAST-1, ILAST ) + A22 = H( ILAST, ILAST ) * * Compute complex Givens rotation on right * (Assume some element of C = (sA - wB) > unfl ) @@ -907,10 +909,10 @@ * IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ $ ABS( C22R )+ABS( C22I ) ) THEN - T = DLAPY3( C12, C11R, C11I ) - CZ = C12 / T - SZR = -C11R / T - SZI = -C11I / T + T1 = DLAPY3( C12, C11R, C11I ) + CZ = C12 / T1 + SZR = -C11R / T1 + SZI = -C11I / T1 ELSE CZ = DLAPY2( C22R, C22I ) IF( CZ.LE.SAFMIN ) THEN @@ -920,10 +922,10 @@ ELSE TEMPR = C22R / CZ TEMPI = C22I / CZ - T = DLAPY2( CZ, C21 ) - CZ = CZ / T - SZR = -C21*TEMPR / T - SZI = C21*TEMPI / T + T1 = DLAPY2( CZ, C21 ) + CZ = CZ / T1 + SZR = -C21*TEMPR / T1 + SZI = C21*TEMPI / T1 END IF END IF * @@ -957,10 +959,10 @@ SQI = TEMPI*A2R - TEMPR*A2I END IF END IF - T = DLAPY3( CQ, SQR, SQI ) - CQ = CQ / T - SQR = SQR / T - SQI = SQI / T + T1 = DLAPY3( CQ, SQR, SQI ) + CQ = CQ / T1 + SQR = SQR / T1 + SQI = SQI / T1 * * Compute diagonal elements of QBZ * @@ -1016,26 +1018,26 @@ * * We assume that the block is at least 3x3 * - AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD22 = ( ASCALE*A( ILAST, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - U12 = B( ILAST-1, ILAST ) / B( ILAST, ILAST ) - AD11L = ( ASCALE*A( IFIRST, IFIRST ) ) / - $ ( BSCALE*B( IFIRST, IFIRST ) ) - AD21L = ( ASCALE*A( IFIRST+1, IFIRST ) ) / - $ ( BSCALE*B( IFIRST, IFIRST ) ) - AD12L = ( ASCALE*A( IFIRST, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - AD22L = ( ASCALE*A( IFIRST+1, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - AD32L = ( ASCALE*A( IFIRST+2, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - U12L = B( IFIRST, IFIRST+1 ) / B( IFIRST+1, IFIRST+1 ) + AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD22 = ( ASCALE*H( ILAST, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) + AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) * V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L @@ -1057,27 +1059,27 @@ * Zero (j-1)st column of A * IF( J.GT.ISTART ) THEN - V( 1 ) = A( J, J-1 ) - V( 2 ) = A( J+1, J-1 ) - V( 3 ) = A( J+2, J-1 ) + V( 1 ) = H( J, J-1 ) + V( 2 ) = H( J+1, J-1 ) + V( 3 ) = H( J+2, J-1 ) * - CALL DLARFG( 3, A( J, J-1 ), V( 2 ), 1, TAU ) + CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE - A( J+1, J-1 ) = ZERO - A( J+2, J-1 ) = ZERO + H( J+1, J-1 ) = ZERO + H( J+2, J-1 ) = ZERO END IF * DO 230 JC = J, ILASTM - TEMP = TAU*( A( J, JC )+V( 2 )*A( J+1, JC )+V( 3 )* - $ A( J+2, JC ) ) - A( J, JC ) = A( J, JC ) - TEMP - A( J+1, JC ) = A( J+1, JC ) - TEMP*V( 2 ) - A( J+2, JC ) = A( J+2, JC ) - TEMP*V( 3 ) - TEMP2 = TAU*( B( J, JC )+V( 2 )*B( J+1, JC )+V( 3 )* - $ B( J+2, JC ) ) - B( J, JC ) = B( J, JC ) - TEMP2 - B( J+1, JC ) = B( J+1, JC ) - TEMP2*V( 2 ) - B( J+2, JC ) = B( J+2, JC ) - TEMP2*V( 3 ) + TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* + $ H( J+2, JC ) ) + H( J, JC ) = H( J, JC ) - TEMP + H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) + H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) + TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* + $ T( J+2, JC ) ) + T( J, JC ) = T( J, JC ) - TEMP2 + T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) + T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) 230 CONTINUE IF( ILQ ) THEN DO 240 JR = 1, N @@ -1094,27 +1096,27 @@ * Swap rows to pivot * ILPIVT = .FALSE. - TEMP = MAX( ABS( B( J+1, J+1 ) ), ABS( B( J+1, J+2 ) ) ) - TEMP2 = MAX( ABS( B( J+2, J+1 ) ), ABS( B( J+2, J+2 ) ) ) + TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) + TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN SCALE = ZERO U1 = ONE U2 = ZERO GO TO 250 ELSE IF( TEMP.GE.TEMP2 ) THEN - W11 = B( J+1, J+1 ) - W21 = B( J+2, J+1 ) - W12 = B( J+1, J+2 ) - W22 = B( J+2, J+2 ) - U1 = B( J+1, J ) - U2 = B( J+2, J ) + W11 = T( J+1, J+1 ) + W21 = T( J+2, J+1 ) + W12 = T( J+1, J+2 ) + W22 = T( J+2, J+2 ) + U1 = T( J+1, J ) + U2 = T( J+2, J ) ELSE - W21 = B( J+1, J+1 ) - W11 = B( J+2, J+1 ) - W22 = B( J+1, J+2 ) - W12 = B( J+2, J+2 ) - U2 = B( J+1, J ) - U1 = B( J+2, J ) + W21 = T( J+1, J+1 ) + W11 = T( J+2, J+1 ) + W22 = T( J+1, J+2 ) + W12 = T( J+2, J+2 ) + U2 = T( J+1, J ) + U1 = T( J+2, J ) END IF * * Swap columns if nec. @@ -1164,9 +1166,9 @@ * * Compute Householder Vector * - T = SQRT( SCALE**2+U1**2+U2**2 ) - TAU = ONE + SCALE / T - VS = -ONE / ( SCALE+T ) + T1 = SQRT( SCALE**2+U1**2+U2**2 ) + TAU = ONE + SCALE / T1 + VS = -ONE / ( SCALE+T1 ) V( 1 ) = ONE V( 2 ) = VS*U1 V( 3 ) = VS*U2 @@ -1174,18 +1176,18 @@ * Apply transformations from the right. * DO 260 JR = IFRSTM, MIN( J+3, ILAST ) - TEMP = TAU*( A( JR, J )+V( 2 )*A( JR, J+1 )+V( 3 )* - $ A( JR, J+2 ) ) - A( JR, J ) = A( JR, J ) - TEMP - A( JR, J+1 ) = A( JR, J+1 ) - TEMP*V( 2 ) - A( JR, J+2 ) = A( JR, J+2 ) - TEMP*V( 3 ) + TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* + $ H( JR, J+2 ) ) + H( JR, J ) = H( JR, J ) - TEMP + H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) + H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) 260 CONTINUE DO 270 JR = IFRSTM, J + 2 - TEMP = TAU*( B( JR, J )+V( 2 )*B( JR, J+1 )+V( 3 )* - $ B( JR, J+2 ) ) - B( JR, J ) = B( JR, J ) - TEMP - B( JR, J+1 ) = B( JR, J+1 ) - TEMP*V( 2 ) - B( JR, J+2 ) = B( JR, J+2 ) - TEMP*V( 3 ) + TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* + $ T( JR, J+2 ) ) + T( JR, J ) = T( JR, J ) - TEMP + T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) + T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) 270 CONTINUE IF( ILZ ) THEN DO 280 JR = 1, N @@ -1196,8 +1198,8 @@ Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) 280 CONTINUE END IF - B( J+1, J ) = ZERO - B( J+2, J ) = ZERO + T( J+1, J ) = ZERO + T( J+2, J ) = ZERO 290 CONTINUE * * Last elements: Use Givens rotations @@ -1205,17 +1207,17 @@ * Rotations from the left * J = ILAST - 1 - TEMP = A( J, J-1 ) - CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = ZERO + TEMP = H( J, J-1 ) + CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO * DO 300 JC = J, ILASTM - TEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = TEMP - TEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = TEMP2 + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 300 CONTINUE IF( ILQ ) THEN DO 310 JR = 1, N @@ -1227,19 +1229,19 @@ * * Rotations from the right. * - TEMP = B( J+1, J+1 ) - CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = ZERO + TEMP = T( J+1, J+1 ) + CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO * DO 320 JR = IFRSTM, ILAST - TEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = TEMP + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP 320 CONTINUE DO 330 JR = IFRSTM, ILAST - 1 - TEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = TEMP + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP 330 CONTINUE IF( ILZ ) THEN DO 340 JR = 1, N @@ -1290,15 +1292,15 @@ * Set Eigenvalues 1:ILO-1 * DO 410 J = 1, ILO - 1 - IF( B( J, J ).LT.ZERO ) THEN + IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 390 JR = 1, J - A( JR, J ) = -A( JR, J ) - B( JR, J ) = -B( JR, J ) + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) 390 CONTINUE ELSE - A( J, J ) = -A( J, J ) - B( J, J ) = -B( J, J ) + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 400 JR = 1, N @@ -1306,9 +1308,9 @@ 400 CONTINUE END IF END IF - ALPHAR( J ) = A( J, J ) + ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO - BETA( J ) = B( J, J ) + BETA( J ) = T( J, J ) 410 CONTINUE * * Normal Termination diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/dtgevc.f LAPACK/TIMING/EIG/EIGSRC/dtgevc.f --- LAPACK.orig/TIMING/EIG/EIGSRC/dtgevc.f Thu Nov 4 14:28:32 1999 +++ LAPACK/TIMING/EIG/EIGSRC/dtgevc.f Fri May 25 16:20:45 2001 @@ -1,18 +1,18 @@ - SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, + SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 4, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE - INTEGER INFO, LDA, LDB, LDVL, LDVR, M, MM, N + INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), VL( LDVL, * ), + DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * @@ -33,35 +33,31 @@ * Purpose * ======= * -* DTGEVC computes some or all of the right and/or left generalized -* eigenvectors of a pair of real upper triangular matrices (A,B). -* -* The right generalized eigenvector x and the left generalized -* eigenvector y of (A,B) corresponding to a generalized eigenvalue -* w are defined by: -* -* (A - wB) * x = 0 and y**H * (A - wB) = 0 -* +* DTGEVC computes some or all of the right and/or left eigenvectors of +* a pair of real matrices (S,P), where S is a quasi-triangular matrix +* and P is upper triangular. Matrix pairs of this type are produced by +* the generalized Schur factorization of a matrix pair (A,B): +* +* A = Q*S*Z**T, B = Q*P*Z**T +* +* as computed by DGGHRD + DHGEQZ. +* +* The right eigenvector x and the left eigenvector y of (S,P) +* corresponding to an eigenvalue w are defined by: +* +* S*x = w*P*x, (y**H)*S = w*(y**H)*P, +* * where y**H denotes the conjugate tranpose of y. -* -* If an eigenvalue w is determined by zero diagonal elements of both A -* and B, a unit vector is returned as the corresponding eigenvector. -* -* If all eigenvectors are requested, the routine may either return -* the matrices X and/or Y of right or left eigenvectors of (A,B), or -* the products Z*X and/or Q*Y, where Z and Q are input orthogonal -* matrices. If (A,B) was obtained from the generalized real-Schur -* factorization of an original pair of matrices -* (A0,B0) = (Q*A*Z**H,Q*B*Z**H), -* then Z*X and Q*Y are the matrices of right or left eigenvectors of -* A. -* -* A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal -* blocks. Corresponding to each 2-by-2 diagonal block is a complex -* conjugate pair of eigenvalues and eigenvectors; only one -* eigenvector of the pair is computed, namely the one corresponding -* to the eigenvalue with positive imaginary part. -* +* The eigenvalues are not input to this routine, but are computed +* directly from the diagonal blocks of S and P. +* +* This routine returns the matrices X and/or Y of right and left +* eigenvectors of (S,P), or the products Z*X and/or Q*Y, +* where Z and Q are input matrices. +* If Q and Z are the orthogonal factors from the generalized Schur +* factorization of a matrix pair (A,B), then Z*X and Q*Y +* are the matrices of right and left eigenvectors of (A,B). +* * Arguments * ========= * @@ -72,78 +68,84 @@ * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; -* = 'B': compute all right and/or left eigenvectors, and -* backtransform them using the input matrices supplied -* in VR and/or VL; +* = 'B': compute all right and/or left eigenvectors, +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY='S', SELECT specifies the eigenvectors to be -* computed. -* If HOWMNY='A' or 'B', SELECT is not referenced. -* To select the real eigenvector corresponding to the real -* eigenvalue w(j), SELECT(j) must be set to .TRUE. To select -* the complex eigenvector corresponding to a complex conjugate -* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must -* be set to .TRUE.. +* computed. If w(j) is a real eigenvalue, the corresponding +* real eigenvector is computed if SELECT(j) is .TRUE.. +* If w(j) and w(j+1) are the real and imaginary parts of a +* complex eigenvalue, the corresponding complex eigenvector +* is computed if either SELECT(j) or SELECT(j+1) is .TRUE., +* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is +* set to .FALSE.. +* Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER -* The order of the matrices A and B. N >= 0. +* The order of the matrices S and P. N >= 0. * -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The upper quasi-triangular matrix A. +* S (input) DOUBLE PRECISION array, dimension (LDS,N) +* The upper quasi-triangular matrix S from a generalized Schur +* factorization, as computed by DHGEQZ. +* +* LDS (input) INTEGER +* The leading dimension of array S. LDS >= max(1,N). +* +* P (input) DOUBLE PRECISION array, dimension (LDP,N) +* The upper triangular matrix P from a generalized Schur +* factorization, as computed by DHGEQZ. +* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks +* of S must be in positive diagonal form. * -* LDA (input) INTEGER -* The leading dimension of array A. LDA >= max(1,N). -* -* B (input) DOUBLE PRECISION array, dimension (LDB,N) -* The upper triangular matrix B. If A has a 2-by-2 diagonal -* block, then the corresponding 2-by-2 block of B must be -* diagonal with positive elements. -* -* LDB (input) INTEGER -* The leading dimension of array B. LDB >= max(1,N). +* LDP (input) INTEGER +* The leading dimension of array P. LDP >= max(1,N). * * VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of left Schur vectors returned by DHGEQZ). * On exit, if SIDE = 'L' or 'B', VL contains: -* if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Q*Y; -* if HOWMNY = 'S', the left eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VL, in the same order as their eigenvalues. -* If SIDE = 'R', VL is not referenced. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. * +* Not referenced if SIDE = 'R'. +* * LDVL (input) INTEGER -* The leading dimension of array VL. -* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must -* contain an N-by-N matrix Q (usually the orthogonal matrix Z +* contain an N-by-N matrix Z (usually the orthogonal matrix Z * of right Schur vectors returned by DHGEQZ). +* * On exit, if SIDE = 'R' or 'B', VR contains: -* if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); -* if HOWMNY = 'B', the matrix Z*X; -* if HOWMNY = 'S', the right eigenvectors of (A,B) specified by -* SELECT, stored consecutively in the columns of -* VR, in the same order as their eigenvalues. -* If SIDE = 'L', VR is not referenced. +* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); +* if HOWMNY = 'B' or 'b', the matrix Z*X; +* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) +* specified by SELECT, stored consecutively in the +* columns of VR, in the same order as their +* eigenvalues. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. +* +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. -* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. @@ -212,7 +214,7 @@ * partial sums. Since FORTRAN arrays are stored columnwise, this has * the advantage that at each step, the elements of C that are accessed * are adjacent to one another, whereas with the rowwise method, the -* elements accessed at a step are spaced LDA (and LDB) words apart. +* elements accessed at a step are spaced LDS (and LDP) words apart. * * When finding left eigenvectors, the matrix in question is the * transpose of the one in storage, so the rowwise method then @@ -239,8 +241,8 @@ $ TEMP2R, ULP, XMAX, XSCALE * .. * .. Local Arrays .. - DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMA( 2, 2 ), - $ SUMB( 2, 2 ) + DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ), + $ SUMP( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME @@ -265,7 +267,7 @@ IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. - ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN + ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. @@ -297,9 +299,9 @@ INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN @@ -318,7 +320,7 @@ GO TO 10 END IF IF( J.LT.N ) THEN - IF( A( J+1, J ).NE.ZERO ) + IF( S( J+1, J ).NE.ZERO ) $ ILCPLX = .TRUE. END IF IF( ILCPLX ) THEN @@ -338,11 +340,11 @@ ILABAD = .FALSE. ILBBAD = .FALSE. DO 20 J = 1, N - 1 - IF( A( J+1, J ).NE.ZERO ) THEN - IF( B( J, J ).EQ.ZERO .OR. B( J+1, J+1 ).EQ.ZERO .OR. - $ B( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. + IF( S( J+1, J ).NE.ZERO ) THEN + IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR. + $ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. IF( J.LT.N-1 ) THEN - IF( A( J+2, J+1 ).NE.ZERO ) + IF( S( J+2, J+1 ).NE.ZERO ) $ ILABAD = .TRUE. END IF END IF @@ -385,30 +387,30 @@ * blocks) of A and B to check for possible overflow in the * triangular solver. * - ANORM = ABS( A( 1, 1 ) ) + ANORM = ABS( S( 1, 1 ) ) IF( N.GT.1 ) - $ ANORM = ANORM + ABS( A( 2, 1 ) ) - BNORM = ABS( B( 1, 1 ) ) + $ ANORM = ANORM + ABS( S( 2, 1 ) ) + BNORM = ABS( P( 1, 1 ) ) WORK( 1 ) = ZERO WORK( N+1 ) = ZERO * DO 50 J = 2, N TEMP = ZERO TEMP2 = ZERO - IF( A( J, J-1 ).EQ.ZERO ) THEN + IF( S( J, J-1 ).EQ.ZERO ) THEN IEND = J - 1 ELSE IEND = J - 2 END IF DO 30 I = 1, IEND - TEMP = TEMP + ABS( A( I, J ) ) - TEMP2 = TEMP2 + ABS( B( I, J ) ) + TEMP = TEMP + ABS( S( I, J ) ) + TEMP2 = TEMP2 + ABS( P( I, J ) ) 30 CONTINUE WORK( J ) = TEMP WORK( N+J ) = TEMP2 DO 40 I = IEND + 1, MIN( J+1, N ) - TEMP = TEMP + ABS( A( I, J ) ) - TEMP2 = TEMP2 + ABS( B( I, J ) ) + TEMP = TEMP + ABS( S( I, J ) ) + TEMP2 = TEMP2 + ABS( P( I, J ) ) 40 CONTINUE ANORM = MAX( ANORM, TEMP ) BNORM = MAX( BNORM, TEMP2 ) @@ -442,7 +444,7 @@ END IF NW = 1 IF( JE.LT.N ) THEN - IF( A( JE+1, JE ).NE.ZERO ) THEN + IF( S( JE+1, JE ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF @@ -461,8 +463,8 @@ * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN - IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN + IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- returns unit eigenvector * @@ -489,10 +491,10 @@ * * Real eigenvalue * - TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, - $ ABS( B( JE, JE ) )*BSCALE, SAFMIN ) - SALFAR = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*B( JE, JE ) )*BSCALE + TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, + $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) + SALFAR = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO @@ -534,7 +536,7 @@ * * Complex eigenvalue * - CALL DLAG2( A( JE, JE ), LDA, B( JE, JE ), LDB, + CALL DLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) BCOEFI = -BCOEFI @@ -566,9 +568,9 @@ * * Compute first two components of eigenvector * - TEMP = ACOEF*A( JE+1, JE ) - TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE ) - TEMP2I = -BCOEFI*B( JE, JE ) + TEMP = ACOEF*S( JE+1, JE ) + TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) + TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO @@ -577,10 +579,10 @@ ELSE WORK( 2*N+JE+1 ) = ONE WORK( 3*N+JE+1 ) = ZERO - TEMP = ACOEF*A( JE, JE+1 ) - WORK( 2*N+JE ) = ( BCOEFR*B( JE+1, JE+1 )-ACOEF* - $ A( JE+1, JE+1 ) ) / TEMP - WORK( 3*N+JE ) = BCOEFI*B( JE+1, JE+1 ) / TEMP + TEMP = ACOEF*S( JE, JE+1 ) + WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF* + $ S( JE+1, JE+1 ) ) / TEMP + WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP END IF XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) ) @@ -610,11 +612,11 @@ END IF * NA = 1 - BDIAG( 1 ) = B( J, J ) + BDIAG( 1 ) = P( J, J ) IF( J.LT.N ) THEN - IF( A( J+1, J ).NE.ZERO ) THEN + IF( S( J+1, J ).NE.ZERO ) THEN IL2BY2 = .TRUE. - BDIAG( 2 ) = B( J+1, J+1 ) + BDIAG( 2 ) = P( J+1, J+1 ) NA = 2 * ---------------- Begin Timing Code ---------------- IN2BY2 = IN2BY2 + 1 @@ -646,13 +648,13 @@ * Compute dot products * * j-1 -* SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) +* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * * To reduce the op count, this is done as * * _ j-1 _ j-1 -* a*conjg( sum A(k,j)*x(k) ) - b*conjg( sum B(k,j)*x(k) ) +* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) * k=je k=je * * which may cause underflow problems if A or B are close @@ -689,15 +691,15 @@ *$PL$ CMCHAR='*' * DO 110 JA = 1, NA - SUMA( JA, JW ) = ZERO - SUMB( JA, JW ) = ZERO + SUMS( JA, JW ) = ZERO + SUMP( JA, JW ) = ZERO * DO 100 JR = JE, J - 1 - SUMA( JA, JW ) = SUMA( JA, JW ) + - $ A( JR, J+JA-1 )* + SUMS( JA, JW ) = SUMS( JA, JW ) + + $ S( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) - SUMB( JA, JW ) = SUMB( JA, JW ) + - $ B( JR, J+JA-1 )* + SUMP( JA, JW ) = SUMP( JA, JW ) + + $ P( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) 100 CONTINUE 110 CONTINUE @@ -717,15 +719,15 @@ * DO 130 JA = 1, NA IF( ILCPLX ) THEN - SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + - $ BCOEFR*SUMB( JA, 1 ) - - $ BCOEFI*SUMB( JA, 2 ) - SUM( JA, 2 ) = -ACOEF*SUMA( JA, 2 ) + - $ BCOEFR*SUMB( JA, 2 ) + - $ BCOEFI*SUMB( JA, 1 ) + SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + + $ BCOEFR*SUMP( JA, 1 ) - + $ BCOEFI*SUMP( JA, 2 ) + SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) + + $ BCOEFR*SUMP( JA, 2 ) + + $ BCOEFI*SUMP( JA, 1 ) ELSE - SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + - $ BCOEFR*SUMB( JA, 1 ) + SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + + $ BCOEFR*SUMP( JA, 1 ) END IF 130 CONTINUE * @@ -733,7 +735,7 @@ * Solve ( a A - b B ) y = SUM(,) * with scaling and perturbation of the denominator * - CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, A( J, J ), LDA, + CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS, $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR, $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP, $ IINFO ) @@ -859,7 +861,7 @@ END IF NW = 1 IF( JE.GT.1 ) THEN - IF( A( JE, JE-1 ).NE.ZERO ) THEN + IF( S( JE, JE-1 ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF @@ -878,8 +880,8 @@ * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN - IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN + IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- returns unit eigenvector * @@ -908,10 +910,10 @@ * * Real eigenvalue * - TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, - $ ABS( B( JE, JE ) )*BSCALE, SAFMIN ) - SALFAR = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*B( JE, JE ) )*BSCALE + TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, + $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) + SALFAR = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO @@ -954,14 +956,14 @@ * (See "Further Details", above.) * DO 260 JR = 1, JE - 1 - WORK( 2*N+JR ) = BCOEFR*B( JR, JE ) - - $ ACOEF*A( JR, JE ) + WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) - + $ ACOEF*S( JR, JE ) 260 CONTINUE ELSE * * Complex eigenvalue * - CALL DLAG2( A( JE-1, JE-1 ), LDA, B( JE-1, JE-1 ), LDB, + CALL DLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) IF( BCOEFI.EQ.ZERO ) THEN @@ -993,9 +995,9 @@ * Compute first two components of eigenvector * and contribution to sums * - TEMP = ACOEF*A( JE, JE-1 ) - TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE ) - TEMP2I = -BCOEFI*B( JE, JE ) + TEMP = ACOEF*S( JE, JE-1 ) + TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) + TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO @@ -1004,10 +1006,10 @@ ELSE WORK( 2*N+JE-1 ) = ONE WORK( 3*N+JE-1 ) = ZERO - TEMP = ACOEF*A( JE-1, JE ) - WORK( 2*N+JE ) = ( BCOEFR*B( JE-1, JE-1 )-ACOEF* - $ A( JE-1, JE-1 ) ) / TEMP - WORK( 3*N+JE ) = BCOEFI*B( JE-1, JE-1 ) / TEMP + TEMP = ACOEF*S( JE-1, JE ) + WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF* + $ S( JE-1, JE-1 ) ) / TEMP + WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP END IF * XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), @@ -1027,12 +1029,12 @@ CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE ) CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE ) DO 270 JR = 1, JE - 2 - WORK( 2*N+JR ) = -CREALA*A( JR, JE-1 ) + - $ CREALB*B( JR, JE-1 ) - - $ CRE2A*A( JR, JE ) + CRE2B*B( JR, JE ) - WORK( 3*N+JR ) = -CIMAGA*A( JR, JE-1 ) + - $ CIMAGB*B( JR, JE-1 ) - - $ CIM2A*A( JR, JE ) + CIM2B*B( JR, JE ) + WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) + + $ CREALB*P( JR, JE-1 ) - + $ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE ) + WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) + + $ CIMAGB*P( JR, JE-1 ) - + $ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE ) 270 CONTINUE END IF * @@ -1054,7 +1056,7 @@ * next iteration to process it (when it will be j:j+1) * IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN - IF( A( J, J-1 ).NE.ZERO ) THEN + IF( S( J, J-1 ).NE.ZERO ) THEN IL2BY2 = .TRUE. * -------------- Begin Timing Code ----------------- IN2BY2 = IN2BY2 + 1 @@ -1062,18 +1064,18 @@ GO TO 370 END IF END IF - BDIAG( 1 ) = B( J, J ) + BDIAG( 1 ) = P( J, J ) IF( IL2BY2 ) THEN NA = 2 - BDIAG( 2 ) = B( J+1, J+1 ) + BDIAG( 2 ) = P( J+1, J+1 ) ELSE NA = 1 END IF * * Compute x(j) (and x(j+1), if 2-by-2 block) * - CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, A( J, J ), - $ LDA, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), + CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ), + $ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN @@ -1096,7 +1098,7 @@ 300 CONTINUE 310 CONTINUE * -* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling +* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( J.GT.1 ) THEN * @@ -1137,19 +1139,19 @@ $ BCOEFR*WORK( 3*N+J+JA-1 ) DO 340 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - - $ CREALA*A( JR, J+JA-1 ) + - $ CREALB*B( JR, J+JA-1 ) + $ CREALA*S( JR, J+JA-1 ) + + $ CREALB*P( JR, J+JA-1 ) WORK( 3*N+JR ) = WORK( 3*N+JR ) - - $ CIMAGA*A( JR, J+JA-1 ) + - $ CIMAGB*B( JR, J+JA-1 ) + $ CIMAGA*S( JR, J+JA-1 ) + + $ CIMAGB*P( JR, J+JA-1 ) 340 CONTINUE ELSE CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) DO 350 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - - $ CREALA*A( JR, J+JA-1 ) + - $ CREALB*B( JR, J+JA-1 ) + $ CREALA*S( JR, J+JA-1 ) + + $ CREALB*P( JR, J+JA-1 ) 350 CONTINUE END IF 360 CONTINUE diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/dtrevc.f LAPACK/TIMING/EIG/EIGSRC/dtrevc.f --- LAPACK.orig/TIMING/EIG/EIGSRC/dtrevc.f Thu Nov 4 14:28:33 1999 +++ LAPACK/TIMING/EIG/EIGSRC/dtrevc.f Fri May 25 16:21:00 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 7, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -30,28 +30,23 @@ * * DTREVC computes some or all of the right and/or left eigenvectors of * a real upper quasi-triangular matrix T. -* +* Matrices of this type are produced by the Schur factorization of +* a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. +* * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: -* -* T*x = w*x, y'*T = w*y' -* -* where y' denotes the conjugate transpose of the vector y. -* -* If all eigenvectors are requested, the routine may either return the -* matrices X and/or Y of right or left eigenvectors of T, or the -* products Q*X and/or Q*Y, where Q is an input orthogonal -* matrix. If T was obtained from the real-Schur factorization of an -* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of -* right or left eigenvectors of A. -* -* T must be in Schur canonical form (as returned by DHSEQR), that is, -* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each -* 2-by-2 diagonal block has its diagonal elements equal and its -* off-diagonal elements of opposite sign. Corresponding to each 2-by-2 -* diagonal block is a complex conjugate pair of eigenvalues and -* eigenvectors; only one eigenvector of the pair is computed, namely -* the one corresponding to the eigenvalue with positive imaginary part. +* +* T*x = w*x, (y**H)*T = w*(y**H) +* +* where y**H denotes the conjugate transpose of y. +* The eigenvalues are not input to this routine, but are read directly +* from the diagonal blocks 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 orthogonal 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 * ========= @@ -64,21 +59,21 @@ * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, -* and backtransform them using the input matrices -* supplied in VR and/or VL; +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, -* specified by the logical array SELECT. +* as indicated by the logical array SELECT. * * SELECT (input/output) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. -* If HOWMNY = 'A' or 'B', SELECT is not referenced. -* To select the real eigenvector corresponding to a real -* eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select -* the complex eigenvector corresponding to a complex conjugate -* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be -* set to .TRUE.; then on exit SELECT(j) is .TRUE. and -* SELECT(j+1) is .FALSE.. +* If w(j) is a real eigenvalue, the corresponding real +* eigenvector is computed if SELECT(j) is .TRUE.. +* If w(j) and w(j+1) are the real and imaginary parts of a +* complex eigenvalue, the corresponding complex eigenvector is +* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and +* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to +* .FALSE.. +* Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER * The order of the matrix T. N >= 0. @@ -95,15 +90,6 @@ * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; -* VL has the same quasi-lower triangular form -* as T'. If T(i,i) is a real eigenvalue, then -* the i-th column VL(i) of VL is its -* corresponding eigenvector. If T(i:i+1,i:i+1) -* is a 2-by-2 block whose eigenvalues are -* complex-conjugate eigenvalues of T, then -* VL(i)+sqrt(-1)*VL(i+1) is the complex -* eigenvector corresponding to the eigenvalue -* with positive real part. * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns @@ -112,11 +98,11 @@ * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of the array VL. LDVL >= max(1,N) if -* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of the array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must @@ -124,15 +110,6 @@ * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; -* VR has the same quasi-upper triangular form -* as T. If T(i,i) is a real eigenvalue, then -* the i-th column VR(i) of VR is its -* corresponding eigenvector. If T(i:i+1,i:i+1) -* is a 2-by-2 block whose eigenvalues are -* complex-conjugate eigenvalues of T, then -* VR(i)+sqrt(-1)*VR(i+1) is the complex -* eigenvector corresponding to the eigenvalue -* with positive real part. * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns @@ -141,11 +118,11 @@ * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. LDVR >= max(1,N) if -* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/sbdsqr.f LAPACK/TIMING/EIG/EIGSRC/sbdsqr.f --- LAPACK.orig/TIMING/EIG/EIGSRC/sbdsqr.f Thu Nov 4 14:28:32 1999 +++ LAPACK/TIMING/EIG/EIGSRC/sbdsqr.f Fri May 25 16:19:49 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. CHARACTER UPLO @@ -26,14 +26,26 @@ * Purpose * ======= * -* SBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. +* SBDSQR 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**T +* +* 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**T*VT instead of +* P**T, for given real input matrices U and VT. When U and VT are the +* orthogonal matrices that reduce a general matrix A to bidiagonal +* form: A = U*B*VT, as computed by SGEBRD, then * -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given real input matrices U, VT, and C. +* A = (U*Q) * S * (P**T*VT) +* +* is the SVD of A. Optionally, the subroutine may also compute Q**T*C +* for a given real input matrix C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, @@ -69,18 +81,17 @@ * order. * * E (input/output) REAL array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E +* 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. E(N) is used for workspace. * * VT (input/output) REAL array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. +* On exit, VT is overwritten by P**T * VT. +* Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. @@ -89,21 +100,22 @@ * U (input/output) REAL array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. -* U is not referenced if NRU = 0. +* Not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) REAL array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. -* On exit, C is overwritten by Q' * C. -* C is not referenced if NCC = 0. +* On exit, C is overwritten by Q**T * 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. * -* WORK (workspace) REAL array, dimension (4*N) +* WORK (workspace) REAL array, dimension (2*N) +* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise * * INFO (output) INTEGER * = 0: successful exit diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/sgghrd.f LAPACK/TIMING/EIG/EIGSRC/sgghrd.f --- LAPACK.orig/TIMING/EIG/EIGSRC/sgghrd.f Thu Nov 4 14:28:29 1999 +++ LAPACK/TIMING/EIG/EIGSRC/sgghrd.f Fri May 25 16:20:10 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ @@ -33,16 +33,32 @@ * * SGGHRD reduces a pair of real matrices (A,B) to generalized upper * Hessenberg form using orthogonal transformations, where A is a -* general matrix and B is upper triangular: Q' * A * Z = H and -* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, -* and Q and Z are orthogonal, and ' means transpose. +* general matrix and B is upper triangular. The form of the +* generalized eigenvalue problem is +* A*x = lambda*B*x, +* and B is typically made upper triangular by computing its QR +* factorization and moving the orthogonal matrix Q to the left side +* of the equation. +* +* This subroutine simultaneously reduces A to a Hessenberg matrix H: +* Q**T*A*Z = H +* and transforms B to another upper triangular matrix T: +* Q**T*B*Z = T +* in order to reduce the problem to its standard form +* H*y = lambda*T*y +* where y = Z**T*x. * * The orthogonal matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be * postmultiplied into input matrices Q1 and Z1, so that * -* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' -* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' +* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T +* +* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T +* +* If Q1 is the orthogonal matrix from the QR factorization of B in the +* original equation A*x = lambda*B*x, then SGGHRD reduces the original +* problem to generalized Hessenberg form. * * Arguments * ========= @@ -66,10 +82,11 @@ * * 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 SGGBAL; otherwise they should be set -* to 1 and N respectively. +* ILO and IHI mark the rows and columns of A which are to be +* reduced. 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 SGGBAL; otherwise they +* should be set to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) REAL array, dimension (LDA, N) @@ -83,33 +100,28 @@ * * B (input/output) REAL array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. -* On exit, the upper triangular matrix T = Q' B Z. The +* On exit, the upper triangular matrix T = Q**T B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) REAL array, dimension (LDQ, N) -* If COMPQ='N': Q is not referenced. -* If COMPQ='I': on entry, Q need not be set, and on exit it -* contains the orthogonal matrix Q, where Q' -* is the product of the Givens transformations -* which are applied to A and B on the left. -* If COMPQ='V': on entry, Q must contain an orthogonal matrix -* Q1, and on exit this is overwritten by Q1*Q. +* On entry, if COMPQ = 'V', the orthogonal matrix Q1, +* typically from the QR factorization of B. +* On exit, if COMPQ='I', the orthogonal matrix Q, and if +* COMPQ = 'V', the product Q1*Q. +* Not referenced if COMPQ='N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * Z (input/output) REAL array, dimension (LDZ, N) -* If COMPZ='N': Z is not referenced. -* If COMPZ='I': on entry, Z need not be set, and on exit it -* contains the orthogonal matrix Z, which is -* the product of the Givens transformations -* which are applied to A and B on the right. -* If COMPZ='V': on entry, Z must contain an orthogonal matrix -* Z1, and on exit this is overwritten by Z1*Z. +* On entry, if COMPZ = 'V', the orthogonal matrix Z1. +* On exit, if COMPZ='I', the orthogonal matrix Z, and if +* COMPZ = 'V', the product Z1*Z. +* Not referenced if COMPZ='N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/shgeqz.f LAPACK/TIMING/EIG/EIGSRC/shgeqz.f --- LAPACK.orig/TIMING/EIG/EIGSRC/shgeqz.f Thu Nov 4 14:28:33 1999 +++ LAPACK/TIMING/EIG/EIGSRC/shgeqz.f Fri May 25 16:20:29 2001 @@ -1,20 +1,20 @@ - SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, + SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 3, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. - REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), - $ B( LDB, * ), BETA( * ), Q( LDQ, * ), WORK( * ), - $ Z( LDZ, * ) + REAL ALPHAI( * ), ALPHAR( * ), BETA( * ), + $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), + $ WORK( * ), Z( LDZ, * ) * .. * ---------------------- Begin Timing Code ------------------------- * Common block to return operation count and iteration count @@ -32,37 +32,56 @@ * Purpose * ======= * -* SHGEQZ implements a single-/double-shift version of the QZ method for -* finding the generalized eigenvalues -* -* w(j)=(ALPHAR(j) + i*ALPHAI(j))/BETAR(j) of the equation -* -* det( A - w(i) B ) = 0 -* -* In addition, the pair A,B may be reduced to generalized Schur form: -* B is upper triangular, and A is block upper triangular, where the -* diagonal blocks are either 1-by-1 or 2-by-2, the 2-by-2 blocks having -* complex generalized eigenvalues (see the description of the argument -* JOB.) -* -* If JOB='S', then the pair (A,B) is simultaneously reduced to Schur -* form by applying one orthogonal tranformation (usually called Q) on -* the left and another (usually called Z) on the right. The 2-by-2 -* upper-triangular diagonal blocks of B corresponding to 2-by-2 blocks -* of A will be reduced to positive diagonal matrices. (I.e., -* if A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) and -* B(j+1,j+1) will be positive.) -* -* If JOB='E', then at each iteration, the same transformations -* are computed, but they are only applied to those parts of A and B -* which are needed to compute ALPHAR, ALPHAI, and BETAR. -* -* If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the orthogonal -* transformations used to reduce (A,B) are accumulated into the arrays -* Q and Z s.t.: -* -* Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* -* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* +* SHGEQZ computes the eigenvalues of a real matrix pair (H,T), +* where H is an upper Hessenberg matrix and T is upper triangular, +* using the double-shift QZ method. +* Matrix pairs of this type are produced by the reduction to +* generalized upper Hessenberg form of a real matrix pair (A,B): +* +* A = Q1*H*Z1**T, B = Q1*T*Z1**T, +* +* as computed by SGGHRD. +* +* If JOB='S', then the Hessenberg-triangular pair (H,T) is +* also reduced to generalized Schur form, +* +* H = Q*S*Z**T, T = Q*P*Z**T, +* +* where Q and Z are orthogonal matrices, P is an upper triangular +* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 +* diagonal blocks. +* +* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair +* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of +* eigenvalues. +* +* Additionally, the 2-by-2 upper triangular diagonal blocks of P +* corresponding to 2-by-2 blocks of S are reduced to positive diagonal +* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, +* P(j,j) > 0, and P(j+1,j+1) > 0. +* +* Optionally, the orthogonal matrix Q from the generalized Schur +* factorization may be postmultiplied into an input matrix Q1, and the +* orthogonal matrix Z may be postmultiplied into an input matrix Z1. +* If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced +* the matrix pair (A,B) to generalized upper Hessenberg form, then the +* output matrices Q1*Q and Z1*Z are the orthogonal factors from the +* generalized Schur factorization of (A,B): +* +* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. +* +* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, +* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is +* complex and beta real. +* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the +* generalized nonsymmetric eigenvalue problem (GNEP) +* A*x = lambda*B*x +* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the +* alternate form of the GNEP +* mu*A*y = B*y. +* Real eigenvalues can be read directly from the generalized Schur +* form: +* alpha = S(i,i), beta = P(i,i). * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), @@ -72,114 +91,98 @@ * ========= * * JOB (input) CHARACTER*1 -* = 'E': compute only ALPHAR, ALPHAI, and BETA. A and B will -* not necessarily be put into generalized Schur form. -* = 'S': put A and B into generalized Schur form, as well -* as computing ALPHAR, ALPHAI, and BETA. +* = 'E': Compute eigenvalues only; +* = 'S': Compute eigenvalues and the Schur form. * * COMPQ (input) CHARACTER*1 -* = 'N': do not modify Q. -* = 'V': multiply the array Q on the right by the transpose of -* the orthogonal tranformation that is applied to the -* left side of A and B to reduce them to Schur form. -* = 'I': like COMPQ='V', except that Q will be initialized to -* the identity first. +* = 'N': Left Schur vectors (Q) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Q +* of left Schur vectors of (H,T) is returned; +* = 'V': Q must contain an orthogonal matrix Q1 on entry and +* the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 -* = 'N': do not modify Z. -* = 'V': multiply the array Z on the right by the orthogonal -* tranformation that is applied to the right side of -* A and B to reduce them to Schur form. -* = 'I': like COMPZ='V', except that Z will be initialized to -* the identity first. +* = 'N': Right Schur vectors (Z) are not computed; +* = 'I': Z is initialized to the unit matrix and the matrix Z +* of right Schur vectors of (H,T) is returned; +* = 'V': Z must contain an orthogonal matrix Z1 on entry and +* the product Z1*Z is returned. * * N (input) INTEGER -* The order of the matrices A, B, Q, and Z. N >= 0. +* The order of the matrices H, T, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* A (input/output) REAL array, dimension (LDA, N) -* On entry, the N-by-N upper Hessenberg matrix A. Elements -* below the subdiagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to generalized Schur form. -* If JOB='E', then on exit A will have been destroyed. -* The diagonal blocks will be correct, but the off-diagonal -* portion will be meaningless. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max( 1, N ). -* -* B (input/output) REAL array, dimension (LDB, N) -* On entry, the N-by-N upper triangular matrix B. Elements -* below the diagonal must be zero. 2-by-2 blocks in B -* corresponding to 2-by-2 blocks in A will be reduced to -* positive diagonal form. (I.e., if A(j+1,j) is non-zero, -* then B(j+1,j)=B(j,j+1)=0 and B(j,j) and B(j+1,j+1) will be -* positive.) -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to Schur form. -* If JOB='E', then on exit B will have been destroyed. -* Elements corresponding to diagonal blocks of A will be -* correct, but the off-diagonal portion will be meaningless. +* ILO and IHI mark the rows and columns of H which are in +* Hessenberg form. It is assumed that A is already upper +* triangular in rows and columns 1:ILO-1 and IHI+1:N. +* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. +* +* H (input/output) REAL array, dimension (LDH, N) +* On entry, the N-by-N upper Hessenberg matrix H. +* On exit, if JOB = 'S', H contains the upper quasi-triangular +* matrix S from the generalized Schur factorization; +* 2-by-2 diagonal blocks (corresponding to complex conjugate +* pairs of eigenvalues) are returned in standard form, with +* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. +* If JOB = 'E', the diagonal blocks of H match those of S, but +* the rest of H is unspecified. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH >= max( 1, N ). +* +* T (input/output) REAL array, dimension (LDT, N) +* On entry, the N-by-N upper triangular matrix T. +* On exit, if JOB = 'S', T contains the upper triangular +* matrix P from the generalized Schur factorization; +* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S +* are reduced to positive diagonal form, i.e., if H(j+1,j) is +* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and +* T(j+1,j+1) > 0. +* If JOB = 'E', the diagonal blocks of T match those of P, but +* the rest of T is unspecified. * -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max( 1, N ). +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max( 1, N ). * * ALPHAR (output) REAL array, dimension (N) -* ALPHAR(1:N) will be set to real parts of the diagonal -* elements of A that would result from reducing A and B to -* Schur form and then further reducing them both to triangular -* form using unitary transformations s.t. the diagonal of B -* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=A(j,j). -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. +* The real parts of each scalar alpha defining an eigenvalue +* of GNEP. * * ALPHAI (output) REAL array, dimension (N) -* ALPHAI(1:N) will be set to imaginary parts of the diagonal -* elements of A that would result from reducing A and B to -* Schur form and then further reducing them both to triangular -* form using unitary transformations s.t. the diagonal of B -* was non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=0. -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. +* The imaginary parts of each scalar alpha defining an +* eigenvalue of GNEP. +* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if +* positive, then the j-th and (j+1)-st eigenvalues are a +* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). * * BETA (output) REAL array, dimension (N) -* BETA(1:N) will be set to the (real) diagonal elements of B -* that would result from reducing A and B to Schur form and -* then further reducing them both to triangular form using -* unitary transformations s.t. the diagonal of B was -* non-negative real. Thus, if A(j,j) is in a 1-by-1 block -* (i.e., A(j+1,j)=A(j,j+1)=0), then BETA(j)=B(j,j). -* Note that the (real or complex) values -* (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the -* generalized eigenvalues of the matrix pencil A - wB. -* (Note that BETA(1:N) will always be non-negative, and no -* BETAI is necessary.) +* The scalars beta that define the eigenvalues of GNEP. +* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and +* beta = BETA(j) represent the j-th eigenvalue of the matrix +* pair (A,B), in one of the forms lambda = alpha/beta or +* mu = beta/alpha. Since either lambda or mu may overflow, +* they should not, in general, be computed. * * Q (input/output) REAL array, dimension (LDQ, N) -* If COMPQ='N', then Q will not be referenced. -* If COMPQ='V' or 'I', then the transpose of the orthogonal -* transformations which are applied to A and B on the left -* will be applied to the array Q on the right. +* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur +* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix +* of left Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) REAL array, dimension (LDZ, N) -* If COMPZ='N', then Z will not be referenced. -* If COMPZ='V' or 'I', then the orthogonal transformations -* which are applied to A and B on the right will be applied -* to the array Z on the right. +* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of +* right Schur vectors of (H,T), and if COMPZ = 'V', the +* orthogonal matrix of right Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. @@ -199,13 +202,12 @@ * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value -* = 1,...,N: the QZ iteration did not converge. (A,B) is not +* = 1,...,N: the QZ iteration did not converge. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO+1,...,N should be correct. -* = N+1,...,2*N: the shift calculation failed. (A,B) is not +* = N+1,...,2*N: the shift calculation failed. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO-N+1,...,N should be correct. -* > 2*N: various "impossible" errors. * * Further Details * =============== @@ -237,7 +239,7 @@ $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ CQ, CR, CZ, ESHIFT, OPST, S, S1, S1INV, S2, $ SAFMAX, SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, - $ SZR, T, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, + $ SZR, T1, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, $ U12, U12L, U2, ULP, VS, W11, W12, W21, W22, $ WABS, WI, WR, WR2 * .. @@ -319,9 +321,9 @@ INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 - ELSE IF( LDA.LT.N ) THEN + ELSE IF( LDH.LT.N ) THEN INFO = -8 - ELSE IF( LDB.LT.N ) THEN + ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -15 @@ -360,8 +362,8 @@ SAFMIN = SLAMCH( 'S' ) SAFMAX = ONE / SAFMIN ULP = SLAMCH( 'E' )*SLAMCH( 'B' ) - ANORM = SLANHS( 'F', IN, A( ILO, ILO ), LDA, WORK ) - BNORM = SLANHS( 'F', IN, B( ILO, ILO ), LDB, WORK ) + ANORM = SLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) + BNORM = SLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) @@ -370,15 +372,15 @@ * Set Eigenvalues IHI+1:N * DO 30 J = IHI + 1, N - IF( B( J, J ).LT.ZERO ) THEN + IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 10 JR = 1, J - A( JR, J ) = -A( JR, J ) - B( JR, J ) = -B( JR, J ) + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) 10 CONTINUE ELSE - A( J, J ) = -A( J, J ) - B( J, J ) = -B( J, J ) + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 20 JR = 1, N @@ -386,9 +388,9 @@ 20 CONTINUE END IF END IF - ALPHAR( J ) = A( J, J ) + ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO - BETA( J ) = B( J, J ) + BETA( J ) = T( J, J ) 30 CONTINUE * * ---------------------- Begin Timing Code ------------------------- @@ -435,8 +437,8 @@ * Split the matrix if possible. * * Two tests: -* 1: A(j,j-1)=0 or j=ILO -* 2: B(j,j)=0 +* 1: H(j,j-1)=0 or j=ILO +* 2: T(j,j)=0 * IF( ILAST.EQ.ILO ) THEN * @@ -444,14 +446,14 @@ * GO TO 80 ELSE - IF( ABS( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN - A( ILAST, ILAST-1 ) = ZERO + IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = ZERO GO TO 80 END IF END IF * - IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN - B( ILAST, ILAST ) = ZERO + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = ZERO GO TO 70 END IF * @@ -459,36 +461,36 @@ * DO 60 J = ILAST - 1, ILO, -1 * -* Test 1: for A(j,j-1)=0 or j=ILO +* Test 1: for H(j,j-1)=0 or j=ILO * IF( J.EQ.ILO ) THEN ILAZRO = .TRUE. ELSE - IF( ABS( A( J, J-1 ) ).LE.ATOL ) THEN - A( J, J-1 ) = ZERO + IF( ABS( H( J, J-1 ) ).LE.ATOL ) THEN + H( J, J-1 ) = ZERO ILAZRO = .TRUE. ELSE ILAZRO = .FALSE. END IF END IF * -* Test 2: for B(j,j)=0 +* Test 2: for T(j,j)=0 * - IF( ABS( B( J, J ) ).LT.BTOL ) THEN - B( J, J ) = ZERO + IF( ABS( T( J, J ) ).LT.BTOL ) THEN + T( J, J ) = ZERO * * Test 1a: Check for 2 consecutive small subdiagonals in A * ILAZR2 = .FALSE. IF( .NOT.ILAZRO ) THEN - TEMP = ABS( A( J, J-1 ) ) - TEMP2 = ABS( A( J, J ) ) + TEMP = ABS( H( J, J-1 ) ) + TEMP2 = ABS( H( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( TEMP*( ASCALE*ABS( A( J+1, J ) ) ).LE.TEMP2* + IF( TEMP*( ASCALE*ABS( H( J+1, J ) ) ).LE.TEMP2* $ ( ASCALE*ATOL ) )ILAZR2 = .TRUE. END IF * @@ -500,26 +502,26 @@ * IF( ILAZRO .OR. ILAZR2 ) THEN DO 40 JCH = J, ILAST - 1 - TEMP = A( JCH, JCH ) - CALL SLARTG( TEMP, A( JCH+1, JCH ), C, S, - $ A( JCH, JCH ) ) - A( JCH+1, JCH ) = ZERO - CALL SROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA, - $ A( JCH+1, JCH+1 ), LDA, C, S ) - CALL SROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB, - $ B( JCH+1, JCH+1 ), LDB, C, S ) + TEMP = H( JCH, JCH ) + CALL SLARTG( TEMP, H( JCH+1, JCH ), C, S, + $ H( JCH, JCH ) ) + H( JCH+1, JCH ) = ZERO + CALL SROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH, + $ H( JCH+1, JCH+1 ), LDH, C, S ) + CALL SROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT, + $ T( JCH+1, JCH+1 ), LDT, C, S ) IF( ILQ ) $ CALL SROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) IF( ILAZR2 ) - $ A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C + $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C ILAZR2 = .FALSE. * * --------------- Begin Timing Code ----------------- OPST = OPST + REAL( 7+12*( ILASTM-JCH )+6*NQ ) * ---------------- End Timing Code ------------------ * - IF( ABS( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN + IF( ABS( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN IF( JCH+1.GE.ILAST ) THEN GO TO 80 ELSE @@ -527,35 +529,35 @@ GO TO 110 END IF END IF - B( JCH+1, JCH+1 ) = ZERO + T( JCH+1, JCH+1 ) = ZERO 40 CONTINUE GO TO 70 ELSE * -* Only test 2 passed -- chase the zero to B(ILAST,ILAST) -* Then process as in the case B(ILAST,ILAST)=0 +* Only test 2 passed -- chase the zero to T(ILAST,ILAST) +* Then process as in the case T(ILAST,ILAST)=0 * DO 50 JCH = J, ILAST - 1 - TEMP = B( JCH, JCH+1 ) - CALL SLARTG( TEMP, B( JCH+1, JCH+1 ), C, S, - $ B( JCH, JCH+1 ) ) - B( JCH+1, JCH+1 ) = ZERO + TEMP = T( JCH, JCH+1 ) + CALL SLARTG( TEMP, T( JCH+1, JCH+1 ), C, S, + $ T( JCH, JCH+1 ) ) + T( JCH+1, JCH+1 ) = ZERO IF( JCH.LT.ILASTM-1 ) - $ CALL SROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB, - $ B( JCH+1, JCH+2 ), LDB, C, S ) - CALL SROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA, - $ A( JCH+1, JCH-1 ), LDA, C, S ) + $ CALL SROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT, + $ T( JCH+1, JCH+2 ), LDT, C, S ) + CALL SROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH, + $ H( JCH+1, JCH-1 ), LDH, C, S ) IF( ILQ ) $ CALL SROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) - TEMP = A( JCH+1, JCH ) - CALL SLARTG( TEMP, A( JCH+1, JCH-1 ), C, S, - $ A( JCH+1, JCH ) ) - A( JCH+1, JCH-1 ) = ZERO - CALL SROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1, - $ A( IFRSTM, JCH-1 ), 1, C, S ) - CALL SROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1, - $ B( IFRSTM, JCH-1 ), 1, C, S ) + TEMP = H( JCH+1, JCH ) + CALL SLARTG( TEMP, H( JCH+1, JCH-1 ), C, S, + $ H( JCH+1, JCH ) ) + H( JCH+1, JCH-1 ) = ZERO + CALL SROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1, + $ H( IFRSTM, JCH-1 ), 1, C, S ) + CALL SROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1, + $ T( IFRSTM, JCH-1 ), 1, C, S ) IF( ILZ ) $ CALL SROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, $ C, S ) @@ -585,18 +587,18 @@ INFO = N + 1 GO TO 420 * -* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a +* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a * 1x1 block. * 70 CONTINUE - TEMP = A( ILAST, ILAST ) - CALL SLARTG( TEMP, A( ILAST, ILAST-1 ), C, S, - $ A( ILAST, ILAST ) ) - A( ILAST, ILAST-1 ) = ZERO - CALL SROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1, - $ A( IFRSTM, ILAST-1 ), 1, C, S ) - CALL SROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1, - $ B( IFRSTM, ILAST-1 ), 1, C, S ) + TEMP = H( ILAST, ILAST ) + CALL SLARTG( TEMP, H( ILAST, ILAST-1 ), C, S, + $ H( ILAST, ILAST ) ) + H( ILAST, ILAST-1 ) = ZERO + CALL SROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1, + $ H( IFRSTM, ILAST-1 ), 1, C, S ) + CALL SROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1, + $ T( IFRSTM, ILAST-1 ), 1, C, S ) IF( ILZ ) $ CALL SROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S ) * @@ -605,19 +607,19 @@ * ---------------------- End Timing Code ------------------------ * * -* A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, +* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, * and BETA * 80 CONTINUE - IF( B( ILAST, ILAST ).LT.ZERO ) THEN + IF( T( ILAST, ILAST ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 90 J = IFRSTM, ILAST - A( J, ILAST ) = -A( J, ILAST ) - B( J, ILAST ) = -B( J, ILAST ) + H( J, ILAST ) = -H( J, ILAST ) + T( J, ILAST ) = -T( J, ILAST ) 90 CONTINUE ELSE - A( ILAST, ILAST ) = -A( ILAST, ILAST ) - B( ILAST, ILAST ) = -B( ILAST, ILAST ) + H( ILAST, ILAST ) = -H( ILAST, ILAST ) + T( ILAST, ILAST ) = -T( ILAST, ILAST ) END IF IF( ILZ ) THEN DO 100 J = 1, N @@ -625,9 +627,9 @@ 100 CONTINUE END IF END IF - ALPHAR( ILAST ) = A( ILAST, ILAST ) + ALPHAR( ILAST ) = H( ILAST, ILAST ) ALPHAI( ILAST ) = ZERO - BETA( ILAST ) = B( ILAST, ILAST ) + BETA( ILAST ) = T( ILAST, ILAST ) * * Go to next block -- exit if finished. * @@ -660,7 +662,7 @@ * Compute single shifts. * * At this point, IFIRST < ILAST, and the diagonal elements of -* B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in +* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in * magnitude) * IF( ( IITER / 10 )*10.EQ.IITER ) THEN @@ -668,10 +670,10 @@ * Exceptional shift. Chosen for no particularly good reason. * (Single shift only.) * - IF( ( REAL( MAXIT )*SAFMIN )*ABS( A( ILAST-1, ILAST ) ).LT. - $ ABS( B( ILAST-1, ILAST-1 ) ) ) THEN - ESHIFT = ESHIFT + A( ILAST-1, ILAST ) / - $ B( ILAST-1, ILAST-1 ) + IF( ( REAL( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT. + $ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN + ESHIFT = ESHIFT + H( ILAST-1, ILAST ) / + $ T( ILAST-1, ILAST-1 ) ELSE ESHIFT = ESHIFT + ONE / ( SAFMIN*REAL( MAXIT ) ) END IF @@ -688,8 +690,8 @@ * bottom-right 2x2 block of A and B. The first eigenvalue * returned by SLAG2 is the Wilkinson shift (AEP p.512), * - CALL SLAG2( A( ILAST-1, ILAST-1 ), LDA, - $ B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, + CALL SLAG2( H( ILAST-1, ILAST-1 ), LDH, + $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ S2, WR, WR2, WI ) * TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) ) @@ -721,14 +723,14 @@ * DO 120 J = ILAST - 1, IFIRST + 1, -1 ISTART = J - TEMP = ABS( S1*A( J, J-1 ) ) - TEMP2 = ABS( S1*A( J, J )-WR*B( J, J ) ) + TEMP = ABS( S1*H( J, J-1 ) ) + TEMP2 = ABS( S1*H( J, J )-WR*T( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( ABS( ( ASCALE*A( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* + IF( ABS( ( ASCALE*H( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* $ TEMP2 )GO TO 130 120 CONTINUE * @@ -739,26 +741,26 @@ * * Initial Q * - TEMP = S1*A( ISTART, ISTART ) - WR*B( ISTART, ISTART ) - TEMP2 = S1*A( ISTART+1, ISTART ) + TEMP = S1*H( ISTART, ISTART ) - WR*T( ISTART, ISTART ) + TEMP2 = S1*H( ISTART+1, ISTART ) CALL SLARTG( TEMP, TEMP2, C, S, TEMPR ) * * Sweep * DO 190 J = ISTART, ILAST - 1 IF( J.GT.ISTART ) THEN - TEMP = A( J, J-1 ) - CALL SLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = ZERO + TEMP = H( J, J-1 ) + CALL SLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO END IF * DO 140 JC = J, ILASTM - TEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = TEMP - TEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = TEMP2 + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 140 CONTINUE IF( ILQ ) THEN DO 150 JR = 1, N @@ -768,19 +770,19 @@ 150 CONTINUE END IF * - TEMP = B( J+1, J+1 ) - CALL SLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = ZERO + TEMP = T( J+1, J+1 ) + CALL SLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO * DO 160 JR = IFRSTM, MIN( J+2, ILAST ) - TEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = TEMP + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP 160 CONTINUE DO 170 JR = IFRSTM, J - TEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = TEMP + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP 170 CONTINUE IF( ILZ ) THEN DO 180 JR = 1, N @@ -816,8 +818,8 @@ * B = ( ) with B11 non-negative. * ( 0 B22 ) * - CALL SLASV2( B( ILAST-1, ILAST-1 ), B( ILAST-1, ILAST ), - $ B( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) + CALL SLASV2( T( ILAST-1, ILAST-1 ), T( ILAST-1, ILAST ), + $ T( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) * IF( B11.LT.ZERO ) THEN CR = -CR @@ -826,17 +828,17 @@ B22 = -B22 END IF * - CALL SROT( ILASTM+1-IFIRST, A( ILAST-1, ILAST-1 ), LDA, - $ A( ILAST, ILAST-1 ), LDA, CL, SL ) - CALL SROT( ILAST+1-IFRSTM, A( IFRSTM, ILAST-1 ), 1, - $ A( IFRSTM, ILAST ), 1, CR, SR ) + CALL SROT( ILASTM+1-IFIRST, H( ILAST-1, ILAST-1 ), LDH, + $ H( ILAST, ILAST-1 ), LDH, CL, SL ) + CALL SROT( ILAST+1-IFRSTM, H( IFRSTM, ILAST-1 ), 1, + $ H( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILAST.LT.ILASTM ) - $ CALL SROT( ILASTM-ILAST, B( ILAST-1, ILAST+1 ), LDB, - $ B( ILAST, ILAST+1 ), LDA, CL, SL ) + $ CALL SROT( ILASTM-ILAST, T( ILAST-1, ILAST+1 ), LDT, + $ T( ILAST, ILAST+1 ), LDH, CL, SL ) IF( IFRSTM.LT.ILAST-1 ) - $ CALL SROT( IFIRST-IFRSTM, B( IFRSTM, ILAST-1 ), 1, - $ B( IFRSTM, ILAST ), 1, CR, SR ) + $ CALL SROT( IFIRST-IFRSTM, T( IFRSTM, ILAST-1 ), 1, + $ T( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILQ ) $ CALL SROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL, @@ -845,17 +847,17 @@ $ CALL SROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR, $ SR ) * - B( ILAST-1, ILAST-1 ) = B11 - B( ILAST-1, ILAST ) = ZERO - B( ILAST, ILAST-1 ) = ZERO - B( ILAST, ILAST ) = B22 + T( ILAST-1, ILAST-1 ) = B11 + T( ILAST-1, ILAST ) = ZERO + T( ILAST, ILAST-1 ) = ZERO + T( ILAST, ILAST ) = B22 * * If B22 is negative, negate column ILAST * IF( B22.LT.ZERO ) THEN DO 210 J = IFRSTM, ILAST - A( J, ILAST ) = -A( J, ILAST ) - B( J, ILAST ) = -B( J, ILAST ) + H( J, ILAST ) = -H( J, ILAST ) + T( J, ILAST ) = -T( J, ILAST ) 210 CONTINUE * IF( ILZ ) THEN @@ -869,8 +871,8 @@ * * Recompute shift * - CALL SLAG2( A( ILAST-1, ILAST-1 ), LDA, - $ B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, + CALL SLAG2( H( ILAST-1, ILAST-1 ), LDH, + $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ TEMP, WR, TEMP2, WI ) * * ------------------- Begin Timing Code ---------------------- @@ -887,10 +889,10 @@ * * Do EISPACK (QZVAL) computation of alpha and beta * - A11 = A( ILAST-1, ILAST-1 ) - A21 = A( ILAST, ILAST-1 ) - A12 = A( ILAST-1, ILAST ) - A22 = A( ILAST, ILAST ) + A11 = H( ILAST-1, ILAST-1 ) + A21 = H( ILAST, ILAST-1 ) + A12 = H( ILAST-1, ILAST ) + A22 = H( ILAST, ILAST ) * * Compute complex Givens rotation on right * (Assume some element of C = (sA - wB) > unfl ) @@ -907,10 +909,10 @@ * IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ $ ABS( C22R )+ABS( C22I ) ) THEN - T = SLAPY3( C12, C11R, C11I ) - CZ = C12 / T - SZR = -C11R / T - SZI = -C11I / T + T1 = SLAPY3( C12, C11R, C11I ) + CZ = C12 / T1 + SZR = -C11R / T1 + SZI = -C11I / T1 ELSE CZ = SLAPY2( C22R, C22I ) IF( CZ.LE.SAFMIN ) THEN @@ -920,10 +922,10 @@ ELSE TEMPR = C22R / CZ TEMPI = C22I / CZ - T = SLAPY2( CZ, C21 ) - CZ = CZ / T - SZR = -C21*TEMPR / T - SZI = C21*TEMPI / T + T1 = SLAPY2( CZ, C21 ) + CZ = CZ / T1 + SZR = -C21*TEMPR / T1 + SZI = C21*TEMPI / T1 END IF END IF * @@ -957,10 +959,10 @@ SQI = TEMPI*A2R - TEMPR*A2I END IF END IF - T = SLAPY3( CQ, SQR, SQI ) - CQ = CQ / T - SQR = SQR / T - SQI = SQI / T + T1 = SLAPY3( CQ, SQR, SQI ) + CQ = CQ / T1 + SQR = SQR / T1 + SQI = SQI / T1 * * Compute diagonal elements of QBZ * @@ -1016,26 +1018,26 @@ * * We assume that the block is at least 3x3 * - AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD22 = ( ASCALE*A( ILAST, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - U12 = B( ILAST-1, ILAST ) / B( ILAST, ILAST ) - AD11L = ( ASCALE*A( IFIRST, IFIRST ) ) / - $ ( BSCALE*B( IFIRST, IFIRST ) ) - AD21L = ( ASCALE*A( IFIRST+1, IFIRST ) ) / - $ ( BSCALE*B( IFIRST, IFIRST ) ) - AD12L = ( ASCALE*A( IFIRST, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - AD22L = ( ASCALE*A( IFIRST+1, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - AD32L = ( ASCALE*A( IFIRST+2, IFIRST+1 ) ) / - $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) - U12L = B( IFIRST, IFIRST+1 ) / B( IFIRST+1, IFIRST+1 ) + AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD22 = ( ASCALE*H( ILAST, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) + AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) * V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L @@ -1057,27 +1059,27 @@ * Zero (j-1)st column of A * IF( J.GT.ISTART ) THEN - V( 1 ) = A( J, J-1 ) - V( 2 ) = A( J+1, J-1 ) - V( 3 ) = A( J+2, J-1 ) + V( 1 ) = H( J, J-1 ) + V( 2 ) = H( J+1, J-1 ) + V( 3 ) = H( J+2, J-1 ) * - CALL SLARFG( 3, A( J, J-1 ), V( 2 ), 1, TAU ) + CALL SLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE - A( J+1, J-1 ) = ZERO - A( J+2, J-1 ) = ZERO + H( J+1, J-1 ) = ZERO + H( J+2, J-1 ) = ZERO END IF * DO 230 JC = J, ILASTM - TEMP = TAU*( A( J, JC )+V( 2 )*A( J+1, JC )+V( 3 )* - $ A( J+2, JC ) ) - A( J, JC ) = A( J, JC ) - TEMP - A( J+1, JC ) = A( J+1, JC ) - TEMP*V( 2 ) - A( J+2, JC ) = A( J+2, JC ) - TEMP*V( 3 ) - TEMP2 = TAU*( B( J, JC )+V( 2 )*B( J+1, JC )+V( 3 )* - $ B( J+2, JC ) ) - B( J, JC ) = B( J, JC ) - TEMP2 - B( J+1, JC ) = B( J+1, JC ) - TEMP2*V( 2 ) - B( J+2, JC ) = B( J+2, JC ) - TEMP2*V( 3 ) + TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* + $ H( J+2, JC ) ) + H( J, JC ) = H( J, JC ) - TEMP + H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) + H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) + TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* + $ T( J+2, JC ) ) + T( J, JC ) = T( J, JC ) - TEMP2 + T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) + T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) 230 CONTINUE IF( ILQ ) THEN DO 240 JR = 1, N @@ -1094,27 +1096,27 @@ * Swap rows to pivot * ILPIVT = .FALSE. - TEMP = MAX( ABS( B( J+1, J+1 ) ), ABS( B( J+1, J+2 ) ) ) - TEMP2 = MAX( ABS( B( J+2, J+1 ) ), ABS( B( J+2, J+2 ) ) ) + TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) + TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN SCALE = ZERO U1 = ONE U2 = ZERO GO TO 250 ELSE IF( TEMP.GE.TEMP2 ) THEN - W11 = B( J+1, J+1 ) - W21 = B( J+2, J+1 ) - W12 = B( J+1, J+2 ) - W22 = B( J+2, J+2 ) - U1 = B( J+1, J ) - U2 = B( J+2, J ) + W11 = T( J+1, J+1 ) + W21 = T( J+2, J+1 ) + W12 = T( J+1, J+2 ) + W22 = T( J+2, J+2 ) + U1 = T( J+1, J ) + U2 = T( J+2, J ) ELSE - W21 = B( J+1, J+1 ) - W11 = B( J+2, J+1 ) - W22 = B( J+1, J+2 ) - W12 = B( J+2, J+2 ) - U2 = B( J+1, J ) - U1 = B( J+2, J ) + W21 = T( J+1, J+1 ) + W11 = T( J+2, J+1 ) + W22 = T( J+1, J+2 ) + W12 = T( J+2, J+2 ) + U2 = T( J+1, J ) + U1 = T( J+2, J ) END IF * * Swap columns if nec. @@ -1164,9 +1166,9 @@ * * Compute Householder Vector * - T = SQRT( SCALE**2+U1**2+U2**2 ) - TAU = ONE + SCALE / T - VS = -ONE / ( SCALE+T ) + T1 = SQRT( SCALE**2+U1**2+U2**2 ) + TAU = ONE + SCALE / T1 + VS = -ONE / ( SCALE+T1 ) V( 1 ) = ONE V( 2 ) = VS*U1 V( 3 ) = VS*U2 @@ -1174,18 +1176,18 @@ * Apply transformations from the right. * DO 260 JR = IFRSTM, MIN( J+3, ILAST ) - TEMP = TAU*( A( JR, J )+V( 2 )*A( JR, J+1 )+V( 3 )* - $ A( JR, J+2 ) ) - A( JR, J ) = A( JR, J ) - TEMP - A( JR, J+1 ) = A( JR, J+1 ) - TEMP*V( 2 ) - A( JR, J+2 ) = A( JR, J+2 ) - TEMP*V( 3 ) + TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* + $ H( JR, J+2 ) ) + H( JR, J ) = H( JR, J ) - TEMP + H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) + H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) 260 CONTINUE DO 270 JR = IFRSTM, J + 2 - TEMP = TAU*( B( JR, J )+V( 2 )*B( JR, J+1 )+V( 3 )* - $ B( JR, J+2 ) ) - B( JR, J ) = B( JR, J ) - TEMP - B( JR, J+1 ) = B( JR, J+1 ) - TEMP*V( 2 ) - B( JR, J+2 ) = B( JR, J+2 ) - TEMP*V( 3 ) + TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* + $ T( JR, J+2 ) ) + T( JR, J ) = T( JR, J ) - TEMP + T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) + T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) 270 CONTINUE IF( ILZ ) THEN DO 280 JR = 1, N @@ -1196,8 +1198,8 @@ Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) 280 CONTINUE END IF - B( J+1, J ) = ZERO - B( J+2, J ) = ZERO + T( J+1, J ) = ZERO + T( J+2, J ) = ZERO 290 CONTINUE * * Last elements: Use Givens rotations @@ -1205,17 +1207,17 @@ * Rotations from the left * J = ILAST - 1 - TEMP = A( J, J-1 ) - CALL SLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = ZERO + TEMP = H( J, J-1 ) + CALL SLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO * DO 300 JC = J, ILASTM - TEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = TEMP - TEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = TEMP2 + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 300 CONTINUE IF( ILQ ) THEN DO 310 JR = 1, N @@ -1227,19 +1229,19 @@ * * Rotations from the right. * - TEMP = B( J+1, J+1 ) - CALL SLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = ZERO + TEMP = T( J+1, J+1 ) + CALL SLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO * DO 320 JR = IFRSTM, ILAST - TEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = TEMP + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP 320 CONTINUE DO 330 JR = IFRSTM, ILAST - 1 - TEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = TEMP + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP 330 CONTINUE IF( ILZ ) THEN DO 340 JR = 1, N @@ -1290,15 +1292,15 @@ * Set Eigenvalues 1:ILO-1 * DO 410 J = 1, ILO - 1 - IF( B( J, J ).LT.ZERO ) THEN + IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 390 JR = 1, J - A( JR, J ) = -A( JR, J ) - B( JR, J ) = -B( JR, J ) + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) 390 CONTINUE ELSE - A( J, J ) = -A( J, J ) - B( J, J ) = -B( J, J ) + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 400 JR = 1, N @@ -1306,9 +1308,9 @@ 400 CONTINUE END IF END IF - ALPHAR( J ) = A( J, J ) + ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO - BETA( J ) = B( J, J ) + BETA( J ) = T( J, J ) 410 CONTINUE * * Normal Termination diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/stgevc.f LAPACK/TIMING/EIG/EIGSRC/stgevc.f --- LAPACK.orig/TIMING/EIG/EIGSRC/stgevc.f Thu Nov 4 14:28:30 1999 +++ LAPACK/TIMING/EIG/EIGSRC/stgevc.f Fri May 25 16:20:41 2001 @@ -1,18 +1,18 @@ - SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, + SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 4, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE - INTEGER INFO, LDA, LDB, LDVL, LDVR, M, MM, N + INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) - REAL A( LDA, * ), B( LDB, * ), VL( LDVL, * ), + REAL P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * @@ -33,35 +33,31 @@ * Purpose * ======= * -* STGEVC computes some or all of the right and/or left generalized -* eigenvectors of a pair of real upper triangular matrices (A,B). -* -* The right generalized eigenvector x and the left generalized -* eigenvector y of (A,B) corresponding to a generalized eigenvalue -* w are defined by: -* -* (A - wB) * x = 0 and y**H * (A - wB) = 0 -* +* STGEVC computes some or all of the right and/or left eigenvectors of +* a pair of real matrices (S,P), where S is a quasi-triangular matrix +* and P is upper triangular. Matrix pairs of this type are produced by +* the generalized Schur factorization of a matrix pair (A,B): +* +* A = Q*S*Z**T, B = Q*P*Z**T +* +* as computed by SGGHRD + SHGEQZ. +* +* The right eigenvector x and the left eigenvector y of (S,P) +* corresponding to an eigenvalue w are defined by: +* +* S*x = w*P*x, (y**H)*S = w*(y**H)*P, +* * where y**H denotes the conjugate tranpose of y. -* -* If an eigenvalue w is determined by zero diagonal elements of both A -* and B, a unit vector is returned as the corresponding eigenvector. -* -* If all eigenvectors are requested, the routine may either return -* the matrices X and/or Y of right or left eigenvectors of (A,B), or -* the products Z*X and/or Q*Y, where Z and Q are input orthogonal -* matrices. If (A,B) was obtained from the generalized real-Schur -* factorization of an original pair of matrices -* (A0,B0) = (Q*A*Z**H,Q*B*Z**H), -* then Z*X and Q*Y are the matrices of right or left eigenvectors of -* A. -* -* A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal -* blocks. Corresponding to each 2-by-2 diagonal block is a complex -* conjugate pair of eigenvalues and eigenvectors; only one -* eigenvector of the pair is computed, namely the one corresponding -* to the eigenvalue with positive imaginary part. -* +* The eigenvalues are not input to this routine, but are computed +* directly from the diagonal blocks of S and P. +* +* This routine returns the matrices X and/or Y of right and left +* eigenvectors of (S,P), or the products Z*X and/or Q*Y, +* where Z and Q are input matrices. +* If Q and Z are the orthogonal factors from the generalized Schur +* factorization of a matrix pair (A,B), then Z*X and Q*Y +* are the matrices of right and left eigenvectors of (A,B). +* * Arguments * ========= * @@ -72,78 +68,84 @@ * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; -* = 'B': compute all right and/or left eigenvectors, and -* backtransform them using the input matrices supplied -* in VR and/or VL; +* = 'B': compute all right and/or left eigenvectors, +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY='S', SELECT specifies the eigenvectors to be -* computed. -* If HOWMNY='A' or 'B', SELECT is not referenced. -* To select the real eigenvector corresponding to the real -* eigenvalue w(j), SELECT(j) must be set to .TRUE. To select -* the complex eigenvector corresponding to a complex conjugate -* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must -* be set to .TRUE.. +* computed. If w(j) is a real eigenvalue, the corresponding +* real eigenvector is computed if SELECT(j) is .TRUE.. +* If w(j) and w(j+1) are the real and imaginary parts of a +* complex eigenvalue, the corresponding complex eigenvector +* is computed if either SELECT(j) or SELECT(j+1) is .TRUE., +* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is +* set to .FALSE.. +* Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER -* The order of the matrices A and B. N >= 0. +* The order of the matrices S and P. N >= 0. * -* A (input) REAL array, dimension (LDA,N) -* The upper quasi-triangular matrix A. +* S (input) REAL array, dimension (LDS,N) +* The upper quasi-triangular matrix S from a generalized Schur +* factorization, as computed by SHGEQZ. +* +* LDS (input) INTEGER +* The leading dimension of array S. LDS >= max(1,N). +* +* P (input) REAL array, dimension (LDP,N) +* The upper triangular matrix P from a generalized Schur +* factorization, as computed by SHGEQZ. +* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks +* of S must be in positive diagonal form. * -* LDA (input) INTEGER -* The leading dimension of array A. LDA >= max(1,N). -* -* B (input) REAL array, dimension (LDB,N) -* The upper triangular matrix B. If A has a 2-by-2 diagonal -* block, then the corresponding 2-by-2 block of B must be -* diagonal with positive elements. -* -* LDB (input) INTEGER -* The leading dimension of array B. LDB >= max(1,N). +* LDP (input) INTEGER +* The leading dimension of array P. LDP >= max(1,N). * * VL (input/output) REAL array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of left Schur vectors returned by SHGEQZ). * On exit, if SIDE = 'L' or 'B', VL contains: -* if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Q*Y; -* if HOWMNY = 'S', the left eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VL, in the same order as their eigenvalues. -* If SIDE = 'R', VL is not referenced. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. * +* Not referenced if SIDE = 'R'. +* * LDVL (input) INTEGER -* The leading dimension of array VL. -* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) REAL array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must -* contain an N-by-N matrix Q (usually the orthogonal matrix Z +* contain an N-by-N matrix Z (usually the orthogonal matrix Z * of right Schur vectors returned by SHGEQZ). +* * On exit, if SIDE = 'R' or 'B', VR contains: -* if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); -* if HOWMNY = 'B', the matrix Z*X; -* if HOWMNY = 'S', the right eigenvectors of (A,B) specified by -* SELECT, stored consecutively in the columns of -* VR, in the same order as their eigenvalues. -* If SIDE = 'L', VR is not referenced. +* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); +* if HOWMNY = 'B' or 'b', the matrix Z*X; +* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) +* specified by SELECT, stored consecutively in the +* columns of VR, in the same order as their +* eigenvalues. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. +* +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. -* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. @@ -212,7 +214,7 @@ * partial sums. Since FORTRAN arrays are stored columnwise, this has * the advantage that at each step, the elements of C that are accessed * are adjacent to one another, whereas with the rowwise method, the -* elements accessed at a step are spaced LDA (and LDB) words apart. +* elements accessed at a step are spaced LDS (and LDP) words apart. * * When finding left eigenvectors, the matrix in question is the * transpose of the one in storage, so the rowwise method then @@ -239,8 +241,8 @@ $ TEMP2R, ULP, XMAX, XSCALE * .. * .. Local Arrays .. - REAL BDIAG( 2 ), SUM( 2, 2 ), SUMA( 2, 2 ), - $ SUMB( 2, 2 ) + REAL BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ), + $ SUMP( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME @@ -265,7 +267,7 @@ IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. - ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN + ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. @@ -297,9 +299,9 @@ INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN @@ -318,7 +320,7 @@ GO TO 10 END IF IF( J.LT.N ) THEN - IF( A( J+1, J ).NE.ZERO ) + IF( S( J+1, J ).NE.ZERO ) $ ILCPLX = .TRUE. END IF IF( ILCPLX ) THEN @@ -338,11 +340,11 @@ ILABAD = .FALSE. ILBBAD = .FALSE. DO 20 J = 1, N - 1 - IF( A( J+1, J ).NE.ZERO ) THEN - IF( B( J, J ).EQ.ZERO .OR. B( J+1, J+1 ).EQ.ZERO .OR. - $ B( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. + IF( S( J+1, J ).NE.ZERO ) THEN + IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR. + $ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. IF( J.LT.N-1 ) THEN - IF( A( J+2, J+1 ).NE.ZERO ) + IF( S( J+2, J+1 ).NE.ZERO ) $ ILABAD = .TRUE. END IF END IF @@ -385,30 +387,30 @@ * blocks) of A and B to check for possible overflow in the * triangular solver. * - ANORM = ABS( A( 1, 1 ) ) + ANORM = ABS( S( 1, 1 ) ) IF( N.GT.1 ) - $ ANORM = ANORM + ABS( A( 2, 1 ) ) - BNORM = ABS( B( 1, 1 ) ) + $ ANORM = ANORM + ABS( S( 2, 1 ) ) + BNORM = ABS( P( 1, 1 ) ) WORK( 1 ) = ZERO WORK( N+1 ) = ZERO * DO 50 J = 2, N TEMP = ZERO TEMP2 = ZERO - IF( A( J, J-1 ).EQ.ZERO ) THEN + IF( S( J, J-1 ).EQ.ZERO ) THEN IEND = J - 1 ELSE IEND = J - 2 END IF DO 30 I = 1, IEND - TEMP = TEMP + ABS( A( I, J ) ) - TEMP2 = TEMP2 + ABS( B( I, J ) ) + TEMP = TEMP + ABS( S( I, J ) ) + TEMP2 = TEMP2 + ABS( P( I, J ) ) 30 CONTINUE WORK( J ) = TEMP WORK( N+J ) = TEMP2 DO 40 I = IEND + 1, MIN( J+1, N ) - TEMP = TEMP + ABS( A( I, J ) ) - TEMP2 = TEMP2 + ABS( B( I, J ) ) + TEMP = TEMP + ABS( S( I, J ) ) + TEMP2 = TEMP2 + ABS( P( I, J ) ) 40 CONTINUE ANORM = MAX( ANORM, TEMP ) BNORM = MAX( BNORM, TEMP2 ) @@ -442,7 +444,7 @@ END IF NW = 1 IF( JE.LT.N ) THEN - IF( A( JE+1, JE ).NE.ZERO ) THEN + IF( S( JE+1, JE ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF @@ -461,8 +463,8 @@ * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN - IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN + IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- returns unit eigenvector * @@ -489,10 +491,10 @@ * * Real eigenvalue * - TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, - $ ABS( B( JE, JE ) )*BSCALE, SAFMIN ) - SALFAR = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*B( JE, JE ) )*BSCALE + TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, + $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) + SALFAR = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO @@ -534,7 +536,7 @@ * * Complex eigenvalue * - CALL SLAG2( A( JE, JE ), LDA, B( JE, JE ), LDB, + CALL SLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) BCOEFI = -BCOEFI @@ -566,9 +568,9 @@ * * Compute first two components of eigenvector * - TEMP = ACOEF*A( JE+1, JE ) - TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE ) - TEMP2I = -BCOEFI*B( JE, JE ) + TEMP = ACOEF*S( JE+1, JE ) + TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) + TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO @@ -577,10 +579,10 @@ ELSE WORK( 2*N+JE+1 ) = ONE WORK( 3*N+JE+1 ) = ZERO - TEMP = ACOEF*A( JE, JE+1 ) - WORK( 2*N+JE ) = ( BCOEFR*B( JE+1, JE+1 )-ACOEF* - $ A( JE+1, JE+1 ) ) / TEMP - WORK( 3*N+JE ) = BCOEFI*B( JE+1, JE+1 ) / TEMP + TEMP = ACOEF*S( JE, JE+1 ) + WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF* + $ S( JE+1, JE+1 ) ) / TEMP + WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP END IF XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) ) @@ -610,11 +612,11 @@ END IF * NA = 1 - BDIAG( 1 ) = B( J, J ) + BDIAG( 1 ) = P( J, J ) IF( J.LT.N ) THEN - IF( A( J+1, J ).NE.ZERO ) THEN + IF( S( J+1, J ).NE.ZERO ) THEN IL2BY2 = .TRUE. - BDIAG( 2 ) = B( J+1, J+1 ) + BDIAG( 2 ) = P( J+1, J+1 ) NA = 2 * ---------------- Begin Timing Code ---------------- IN2BY2 = IN2BY2 + 1 @@ -646,13 +648,13 @@ * Compute dot products * * j-1 -* SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) +* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * * To reduce the op count, this is done as * * _ j-1 _ j-1 -* a*conjg( sum A(k,j)*x(k) ) - b*conjg( sum B(k,j)*x(k) ) +* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) * k=je k=je * * which may cause underflow problems if A or B are close @@ -689,15 +691,15 @@ *$PL$ CMCHAR='*' * DO 110 JA = 1, NA - SUMA( JA, JW ) = ZERO - SUMB( JA, JW ) = ZERO + SUMS( JA, JW ) = ZERO + SUMP( JA, JW ) = ZERO * DO 100 JR = JE, J - 1 - SUMA( JA, JW ) = SUMA( JA, JW ) + - $ A( JR, J+JA-1 )* + SUMS( JA, JW ) = SUMS( JA, JW ) + + $ S( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) - SUMB( JA, JW ) = SUMB( JA, JW ) + - $ B( JR, J+JA-1 )* + SUMP( JA, JW ) = SUMP( JA, JW ) + + $ P( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) 100 CONTINUE 110 CONTINUE @@ -717,15 +719,15 @@ * DO 130 JA = 1, NA IF( ILCPLX ) THEN - SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + - $ BCOEFR*SUMB( JA, 1 ) - - $ BCOEFI*SUMB( JA, 2 ) - SUM( JA, 2 ) = -ACOEF*SUMA( JA, 2 ) + - $ BCOEFR*SUMB( JA, 2 ) + - $ BCOEFI*SUMB( JA, 1 ) + SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + + $ BCOEFR*SUMP( JA, 1 ) - + $ BCOEFI*SUMP( JA, 2 ) + SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) + + $ BCOEFR*SUMP( JA, 2 ) + + $ BCOEFI*SUMP( JA, 1 ) ELSE - SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + - $ BCOEFR*SUMB( JA, 1 ) + SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + + $ BCOEFR*SUMP( JA, 1 ) END IF 130 CONTINUE * @@ -733,7 +735,7 @@ * Solve ( a A - b B ) y = SUM(,) * with scaling and perturbation of the denominator * - CALL SLALN2( .TRUE., NA, NW, DMIN, ACOEF, A( J, J ), LDA, + CALL SLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS, $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR, $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP, $ IINFO ) @@ -859,7 +861,7 @@ END IF NW = 1 IF( JE.GT.1 ) THEN - IF( A( JE, JE-1 ).NE.ZERO ) THEN + IF( S( JE, JE-1 ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF @@ -878,8 +880,8 @@ * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN - IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN + IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- returns unit eigenvector * @@ -908,10 +910,10 @@ * * Real eigenvalue * - TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, - $ ABS( B( JE, JE ) )*BSCALE, SAFMIN ) - SALFAR = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*B( JE, JE ) )*BSCALE + TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, + $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) + SALFAR = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO @@ -954,14 +956,14 @@ * (See "Further Details", above.) * DO 260 JR = 1, JE - 1 - WORK( 2*N+JR ) = BCOEFR*B( JR, JE ) - - $ ACOEF*A( JR, JE ) + WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) - + $ ACOEF*S( JR, JE ) 260 CONTINUE ELSE * * Complex eigenvalue * - CALL SLAG2( A( JE-1, JE-1 ), LDA, B( JE-1, JE-1 ), LDB, + CALL SLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) IF( BCOEFI.EQ.ZERO ) THEN @@ -993,9 +995,9 @@ * Compute first two components of eigenvector * and contribution to sums * - TEMP = ACOEF*A( JE, JE-1 ) - TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE ) - TEMP2I = -BCOEFI*B( JE, JE ) + TEMP = ACOEF*S( JE, JE-1 ) + TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) + TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO @@ -1004,10 +1006,10 @@ ELSE WORK( 2*N+JE-1 ) = ONE WORK( 3*N+JE-1 ) = ZERO - TEMP = ACOEF*A( JE-1, JE ) - WORK( 2*N+JE ) = ( BCOEFR*B( JE-1, JE-1 )-ACOEF* - $ A( JE-1, JE-1 ) ) / TEMP - WORK( 3*N+JE ) = BCOEFI*B( JE-1, JE-1 ) / TEMP + TEMP = ACOEF*S( JE-1, JE ) + WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF* + $ S( JE-1, JE-1 ) ) / TEMP + WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP END IF * XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), @@ -1027,12 +1029,12 @@ CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE ) CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE ) DO 270 JR = 1, JE - 2 - WORK( 2*N+JR ) = -CREALA*A( JR, JE-1 ) + - $ CREALB*B( JR, JE-1 ) - - $ CRE2A*A( JR, JE ) + CRE2B*B( JR, JE ) - WORK( 3*N+JR ) = -CIMAGA*A( JR, JE-1 ) + - $ CIMAGB*B( JR, JE-1 ) - - $ CIM2A*A( JR, JE ) + CIM2B*B( JR, JE ) + WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) + + $ CREALB*P( JR, JE-1 ) - + $ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE ) + WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) + + $ CIMAGB*P( JR, JE-1 ) - + $ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE ) 270 CONTINUE END IF * @@ -1054,7 +1056,7 @@ * next iteration to process it (when it will be j:j+1) * IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN - IF( A( J, J-1 ).NE.ZERO ) THEN + IF( S( J, J-1 ).NE.ZERO ) THEN IL2BY2 = .TRUE. * -------------- Begin Timing Code ----------------- IN2BY2 = IN2BY2 + 1 @@ -1062,18 +1064,18 @@ GO TO 370 END IF END IF - BDIAG( 1 ) = B( J, J ) + BDIAG( 1 ) = P( J, J ) IF( IL2BY2 ) THEN NA = 2 - BDIAG( 2 ) = B( J+1, J+1 ) + BDIAG( 2 ) = P( J+1, J+1 ) ELSE NA = 1 END IF * * Compute x(j) (and x(j+1), if 2-by-2 block) * - CALL SLALN2( .FALSE., NA, NW, DMIN, ACOEF, A( J, J ), - $ LDA, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), + CALL SLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ), + $ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN @@ -1096,7 +1098,7 @@ 300 CONTINUE 310 CONTINUE * -* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling +* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( J.GT.1 ) THEN * @@ -1137,19 +1139,19 @@ $ BCOEFR*WORK( 3*N+J+JA-1 ) DO 340 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - - $ CREALA*A( JR, J+JA-1 ) + - $ CREALB*B( JR, J+JA-1 ) + $ CREALA*S( JR, J+JA-1 ) + + $ CREALB*P( JR, J+JA-1 ) WORK( 3*N+JR ) = WORK( 3*N+JR ) - - $ CIMAGA*A( JR, J+JA-1 ) + - $ CIMAGB*B( JR, J+JA-1 ) + $ CIMAGA*S( JR, J+JA-1 ) + + $ CIMAGB*P( JR, J+JA-1 ) 340 CONTINUE ELSE CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) DO 350 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - - $ CREALA*A( JR, J+JA-1 ) + - $ CREALB*B( JR, J+JA-1 ) + $ CREALA*S( JR, J+JA-1 ) + + $ CREALB*P( JR, J+JA-1 ) 350 CONTINUE END IF 360 CONTINUE diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/strevc.f LAPACK/TIMING/EIG/EIGSRC/strevc.f --- LAPACK.orig/TIMING/EIG/EIGSRC/strevc.f Thu Nov 4 14:28:33 1999 +++ LAPACK/TIMING/EIG/EIGSRC/strevc.f Fri May 25 16:20:57 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 7, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -30,28 +30,23 @@ * * STREVC computes some or all of the right and/or left eigenvectors of * a real upper quasi-triangular matrix T. -* +* Matrices of this type are produced by the Schur factorization of +* a real general matrix: A = Q*T*Q**T, as computed by SHSEQR. +* * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: -* -* T*x = w*x, y'*T = w*y' -* -* where y' denotes the conjugate transpose of the vector y. -* -* If all eigenvectors are requested, the routine may either return the -* matrices X and/or Y of right or left eigenvectors of T, or the -* products Q*X and/or Q*Y, where Q is an input orthogonal -* matrix. If T was obtained from the real-Schur factorization of an -* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of -* right or left eigenvectors of A. -* -* T must be in Schur canonical form (as returned by SHSEQR), that is, -* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each -* 2-by-2 diagonal block has its diagonal elements equal and its -* off-diagonal elements of opposite sign. Corresponding to each 2-by-2 -* diagonal block is a complex conjugate pair of eigenvalues and -* eigenvectors; only one eigenvector of the pair is computed, namely -* the one corresponding to the eigenvalue with positive imaginary part. +* +* T*x = w*x, (y**H)*T = w*(y**H) +* +* where y**H denotes the conjugate transpose of y. +* The eigenvalues are not input to this routine, but are read directly +* from the diagonal blocks 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 orthogonal 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 * ========= @@ -64,21 +59,21 @@ * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, -* and backtransform them using the input matrices -* supplied in VR and/or VL; +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, -* specified by the logical array SELECT. +* as indicated by the logical array SELECT. * * SELECT (input/output) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. -* If HOWMNY = 'A' or 'B', SELECT is not referenced. -* To select the real eigenvector corresponding to a real -* eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select -* the complex eigenvector corresponding to a complex conjugate -* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be -* set to .TRUE.; then on exit SELECT(j) is .TRUE. and -* SELECT(j+1) is .FALSE.. +* If w(j) is a real eigenvalue, the corresponding real +* eigenvector is computed if SELECT(j) is .TRUE.. +* If w(j) and w(j+1) are the real and imaginary parts of a +* complex eigenvalue, the corresponding complex eigenvector is +* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and +* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to +* .FALSE.. +* Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER * The order of the matrix T. N >= 0. @@ -95,15 +90,6 @@ * of Schur vectors returned by SHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; -* VL has the same quasi-lower triangular form -* as T'. If T(i,i) is a real eigenvalue, then -* the i-th column VL(i) of VL is its -* corresponding eigenvector. If T(i:i+1,i:i+1) -* is a 2-by-2 block whose eigenvalues are -* complex-conjugate eigenvalues of T, then -* VL(i)+sqrt(-1)*VL(i+1) is the complex -* eigenvector corresponding to the eigenvalue -* with positive real part. * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns @@ -112,11 +98,11 @@ * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of the array VL. LDVL >= max(1,N) if -* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of the array VL. LDVL >= 1, and if +* SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) REAL array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must @@ -124,15 +110,6 @@ * of Schur vectors returned by SHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; -* VR has the same quasi-upper triangular form -* as T. If T(i,i) is a real eigenvalue, then -* the i-th column VR(i) of VR is its -* corresponding eigenvector. If T(i:i+1,i:i+1) -* is a 2-by-2 block whose eigenvalues are -* complex-conjugate eigenvalues of T, then -* VR(i)+sqrt(-1)*VR(i+1) is the complex -* eigenvector corresponding to the eigenvalue -* with positive real part. * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns @@ -141,11 +118,11 @@ * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. LDVR >= max(1,N) if -* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/zbdsqr.f LAPACK/TIMING/EIG/EIGSRC/zbdsqr.f --- LAPACK.orig/TIMING/EIG/EIGSRC/zbdsqr.f Thu Nov 4 14:28:30 1999 +++ LAPACK/TIMING/EIG/EIGSRC/zbdsqr.f Fri May 25 16:20:01 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. CHARACTER UPLO @@ -26,14 +26,26 @@ * Purpose * ======= * -* ZBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. +* 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 * -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given complex input matrices U, VT, and C. +* 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, @@ -69,18 +81,17 @@ * order. * * E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E +* 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. E(N) is used for workspace. * * VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. +* On exit, VT is overwritten by P**H * VT. +* Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. @@ -89,21 +100,22 @@ * 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. -* U is not referenced if NRU = 0. +* 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' * C. -* C is not referenced if NCC = 0. +* 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 (4*N) +* 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 diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/zgghrd.f LAPACK/TIMING/EIG/EIGSRC/zgghrd.f --- LAPACK.orig/TIMING/EIG/EIGSRC/zgghrd.f Thu Nov 4 14:28:32 1999 +++ LAPACK/TIMING/EIG/EIGSRC/zgghrd.f Fri May 25 16:20:24 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 +* April 26, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ @@ -33,16 +33,29 @@ * * ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper * Hessenberg form using unitary transformations, where A is a -* general matrix and B is upper triangular: Q' * A * Z = H and -* Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, -* and Q and Z are unitary, and ' means conjugate transpose. +* general matrix and B is upper triangular. The form of the +* generalized eigenvalue problem is +* A*x = lambda*B*x, +* and B is typically made upper triangular by computing its QR +* factorization and moving the unitary matrix Q to the left side +* of the equation. +* +* This subroutine simultaneously reduces A to a Hessenberg matrix H: +* Q**H*A*Z = H +* and transforms B to another upper triangular matrix T: +* Q**H*B*Z = T +* in order to reduce the problem to its standard form +* H*y = lambda*T*y +* where y = Z**H*x. * * The unitary matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be * postmultiplied into input matrices Q1 and Z1, so that -* -* Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' -* Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' +* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H +* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H +* If Q1 is the unitary matrix from the QR factorization of B in the +* original equation A*x = lambda*B*x, then ZGGHRD reduces the original +* problem to generalized Hessenberg form. * * Arguments * ========= @@ -66,10 +79,11 @@ * * 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 ZGGBAL; otherwise they should be set -* to 1 and N respectively. +* ILO and IHI mark the rows and columns of A which are to be +* reduced. 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 ZGGBAL; otherwise they +* should be set to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) COMPLEX*16 array, dimension (LDA, N) @@ -83,33 +97,28 @@ * * B (input/output) COMPLEX*16 array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. -* On exit, the upper triangular matrix T = Q' B Z. The +* On exit, the upper triangular matrix T = Q**H B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) COMPLEX*16 array, dimension (LDQ, N) -* If COMPQ='N': Q is not referenced. -* If COMPQ='I': on entry, Q need not be set, and on exit it -* contains the unitary matrix Q, where Q' -* is the product of the Givens transformations -* which are applied to A and B on the left. -* If COMPQ='V': on entry, Q must contain a unitary matrix -* Q1, and on exit this is overwritten by Q1*Q. +* On entry, if COMPQ = 'V', the unitary matrix Q1, typically +* from the QR factorization of B. +* On exit, if COMPQ='I', the unitary matrix Q, and if +* COMPQ = 'V', the product Q1*Q. +* Not referenced if COMPQ='N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * 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 it -* contains the unitary matrix Z, which is -* the product of the Givens transformations -* which are applied to A and B on the right. -* If COMPZ='V': on entry, Z must contain a unitary matrix -* Z1, and on exit this is overwritten by Z1*Z. +* On entry, if COMPZ = 'V', the unitary matrix Z1. +* On exit, if COMPZ='I', the unitary matrix Z, and if +* COMPZ = 'V', the product Z1*Z. +* Not referenced if COMPZ='N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/zhgeqz.f LAPACK/TIMING/EIG/EIGSRC/zhgeqz.f --- LAPACK.orig/TIMING/EIG/EIGSRC/zhgeqz.f Thu Nov 4 14:28:33 1999 +++ LAPACK/TIMING/EIG/EIGSRC/zhgeqz.f Fri May 25 16:20:38 2001 @@ -1,20 +1,21 @@ - SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, + SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, $ RWORK, INFO ) * * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 3, 2001 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ) - COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), - $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) + COMPLEX*16 ALPHA( * ), BETA( * ), H( LDH, * ), + $ Q( LDQ, * ), T( LDT, * ), WORK( * ), + $ Z( LDZ, * ) * .. * * ----------------------- Begin Timing Code ------------------------ @@ -34,24 +35,44 @@ * Purpose * ======= * -* ZHGEQZ implements a single-shift version of the QZ -* method for finding the generalized eigenvalues w(i)=ALPHA(i)/BETA(i) -* of the equation -* -* det( A - w(i) B ) = 0 -* -* If JOB='S', then the pair (A,B) is simultaneously -* reduced to Schur form (i.e., A and B are both upper triangular) by -* applying one unitary tranformation (usually called Q) on the left and -* another (usually called Z) on the right. The diagonal elements of -* A are then ALPHA(1),...,ALPHA(N), and of B are BETA(1),...,BETA(N). -* -* If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the unitary -* transformations used to reduce (A,B) are accumulated into the arrays -* Q and Z s.t.: -* -* Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* -* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* +* ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T), +* where H is an upper Hessenberg matrix and T is upper triangular, +* using the single-shift QZ method. +* Matrix pairs of this type are produced by the reduction to +* generalized upper Hessenberg form of a complex matrix pair (A,B): +* +* A = Q1*H*Z1**H, B = Q1*T*Z1**H, +* +* as computed by ZGGHRD. +* +* If JOB='S', then the Hessenberg-triangular pair (H,T) is +* also reduced to generalized Schur form, +* +* H = Q*S*Z**H, T = Q*P*Z**H, +* +* where Q and Z are unitary matrices and S and P are upper triangular. +* +* Optionally, the unitary matrix Q from the generalized Schur +* factorization may be postmultiplied into an input matrix Q1, and the +* unitary matrix Z may be postmultiplied into an input matrix Z1. +* If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced +* the matrix pair (A,B) to generalized Hessenberg form, then the output +* matrices Q1*Q and Z1*Z are the unitary factors from the generalized +* Schur factorization of (A,B): +* +* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. +* +* To avoid overflow, eigenvalues of the matrix pair (H,T) +* (equivalently, of (A,B)) are computed as a pair of complex values +* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an +* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) +* A*x = lambda*B*x +* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the +* alternate form of the GNEP +* mu*A*y = B*y. +* The values of alpha and beta for the i-th eigenvalue can be read +* directly from the generalized Schur form: alpha = S(i,i), +* beta = P(i,i). * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), @@ -61,83 +82,88 @@ * ========= * * JOB (input) CHARACTER*1 -* = 'E': compute only ALPHA and BETA. A and B will not -* necessarily be put into generalized Schur form. -* = 'S': put A and B into generalized Schur form, as well -* as computing ALPHA and BETA. +* = 'E': Compute eigenvalues only; +* = 'S': Computer eigenvalues and the Schur form. * * COMPQ (input) CHARACTER*1 -* = 'N': do not modify Q. -* = 'V': multiply the array Q on the right by the conjugate -* transpose of the unitary tranformation that is -* applied to the left side of A and B to reduce them -* to Schur form. -* = 'I': like COMPQ='V', except that Q will be initialized to -* the identity first. +* = 'N': Left Schur vectors (Q) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Q +* of left Schur vectors of (H,T) is returned; +* = 'V': Q must contain a unitary matrix Q1 on entry and +* the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 -* = 'N': do not modify Z. -* = 'V': multiply the array Z on the right by the unitary -* tranformation that is applied to the right side of -* A and B to reduce them to Schur form. -* = 'I': like COMPZ='V', except that Z will be initialized to -* the identity first. +* = 'N': Right Schur vectors (Z) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Z +* of right Schur vectors of (H,T) is returned; +* = 'V': Z must contain a unitary matrix Z1 on entry and +* the product Z1*Z is returned. * * N (input) INTEGER -* The order of the matrices A, B, Q, and Z. N >= 0. +* The order of the matrices H, T, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER -* It is assumed that A is already upper triangular in rows and -* columns 1:ILO-1 and IHI+1:N. -* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA, N) -* On entry, the N-by-N upper Hessenberg matrix A. Elements -* below the subdiagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to upper triangular form. -* If JOB='E', then on exit A will have been destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max( 1, N ). -* -* B (input/output) COMPLEX*16 array, dimension (LDB, N) -* On entry, the N-by-N upper triangular matrix B. Elements -* below the diagonal must be zero. -* If JOB='S', then on exit A and B will have been -* simultaneously reduced to upper triangular form. -* If JOB='E', then on exit B will have been destroyed. +* ILO and IHI mark the rows and columns of H which are in +* Hessenberg form. It is assumed that A is already upper +* triangular in rows and columns 1:ILO-1 and IHI+1:N. +* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. +* +* H (input/output) COMPLEX*16 array, dimension (LDH, N) +* On entry, the N-by-N upper Hessenberg matrix H. +* On exit, if JOB = 'S', H contains the upper triangular +* matrix S from the generalized Schur factorization. +* If JOB = 'E', the diagonal of H matches that of S, but +* the rest of H is unspecified. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH >= max( 1, N ). +* +* T (input/output) COMPLEX*16 array, dimension (LDT, N) +* On entry, the N-by-N upper triangular matrix T. +* On exit, if JOB = 'S', T contains the upper triangular +* matrix P from the generalized Schur factorization. +* If JOB = 'E', the diagonal of T matches that of P, but +* the rest of T is unspecified. * -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max( 1, N ). +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max( 1, N ). * * ALPHA (output) COMPLEX*16 array, dimension (N) -* The diagonal elements of A when the pair (A,B) has been -* reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N -* are the generalized eigenvalues. +* The complex scalars alpha that define the eigenvalues of +* GNEP. ALPHA(i) = S(i,i) in the generalized Schur +* factorization. * * BETA (output) COMPLEX*16 array, dimension (N) -* The diagonal elements of B when the pair (A,B) has been -* reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N -* are the generalized eigenvalues. A and B are normalized -* so that BETA(1),...,BETA(N) are non-negative real numbers. +* The real non-negative scalars beta that define the +* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized +* Schur factorization. +* +* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) +* represent the j-th eigenvalue of the matrix pair (A,B), in +* one of the forms lambda = alpha/beta or mu = beta/alpha. +* Since either lambda or mu may overflow, they should not, +* in general, be computed. * * Q (input/output) COMPLEX*16 array, dimension (LDQ, N) -* If COMPQ='N', then Q will not be referenced. -* If COMPQ='V' or 'I', then the conjugate transpose of the -* unitary transformations which are applied to A and B on -* the left will be applied to the array Q on the right. +* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the +* reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the unitary matrix of left Schur +* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of +* left Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) COMPLEX*16 array, dimension (LDZ, N) -* If COMPZ='N', then Z will not be referenced. -* If COMPZ='V' or 'I', then the unitary transformations which -* are applied to A and B on the right will be applied to the -* array Z on the right. +* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the +* reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the unitary matrix of right Schur +* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of +* right Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. @@ -159,13 +185,12 @@ * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value -* = 1,...,N: the QZ iteration did not converge. (A,B) is not +* = 1,...,N: the QZ iteration did not converge. (H,T) is not * in Schur form, but ALPHA(i) and BETA(i), * i=INFO+1,...,N should be correct. -* = N+1,...,2*N: the shift calculation failed. (A,B) is not +* = N+1,...,2*N: the shift calculation failed. (H,T) is not * in Schur form, but ALPHA(i) and BETA(i), * i=INFO-N+1,...,N should be correct. -* > 2*N: various "impossible" errors. * * Further Details * =============== @@ -192,7 +217,7 @@ DOUBLE PRECISION ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL, $ C, OPST, SAFMIN, TEMP, TEMP2, TEMPR, ULP COMPLEX*16 ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2, - $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T, + $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1, $ U12, X * .. * .. External Functions .. @@ -279,9 +304,9 @@ INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 - ELSE IF( LDA.LT.N ) THEN + ELSE IF( LDH.LT.N ) THEN INFO = -8 - ELSE IF( LDB.LT.N ) THEN + ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -14 @@ -317,8 +342,8 @@ IN = IHI + 1 - ILO SAFMIN = DLAMCH( 'S' ) ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) - ANORM = ZLANHS( 'F', IN, A( ILO, ILO ), LDA, RWORK ) - BNORM = ZLANHS( 'F', IN, B( ILO, ILO ), LDB, RWORK ) + ANORM = ZLANHS( 'F', IN, H( ILO, ILO ), LDH, RWORK ) + BNORM = ZLANHS( 'F', IN, T( ILO, ILO ), LDT, RWORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) @@ -335,18 +360,18 @@ * Set Eigenvalues IHI+1:N * DO 10 J = IHI + 1, N - ABSB = ABS( B( J, J ) ) + ABSB = ABS( T( J, J ) ) IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = DCONJG( B( J, J ) / ABSB ) - B( J, J ) = ABSB + SIGNBC = DCONJG( T( J, J ) / ABSB ) + T( J, J ) = ABSB IF( ILSCHR ) THEN - CALL ZSCAL( J-1, SIGNBC, B( 1, J ), 1 ) - CALL ZSCAL( J, SIGNBC, A( 1, J ), 1 ) + CALL ZSCAL( J-1, SIGNBC, T( 1, J ), 1 ) + CALL ZSCAL( J, SIGNBC, H( 1, J ), 1 ) * ----------------- Begin Timing Code --------------------- OPST = OPST + DBLE( 12*( J-1 ) ) * ------------------ End Timing Code ---------------------- ELSE - A( J, J ) = A( J, J )*SIGNBC + H( J, J ) = H( J, J )*SIGNBC END IF IF( ILZ ) $ CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 ) @@ -354,10 +379,10 @@ OPST = OPST + DBLE( 6*NZ+13 ) * -------------------- End Timing Code ----------------------- ELSE - B( J, J ) = CZERO + T( J, J ) = CZERO END IF - ALPHA( J ) = A( J, J ) - BETA( J ) = B( J, J ) + ALPHA( J ) = H( J, J ) + BETA( J ) = T( J, J ) 10 CONTINUE * * If IHI < ILO, skip QZ steps @@ -402,22 +427,22 @@ * Split the matrix if possible. * * Two tests: -* 1: A(j,j-1)=0 or j=ILO -* 2: B(j,j)=0 +* 1: H(j,j-1)=0 or j=ILO +* 2: T(j,j)=0 * * Special case: j=ILAST * IF( ILAST.EQ.ILO ) THEN GO TO 60 ELSE - IF( ABS1( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN - A( ILAST, ILAST-1 ) = CZERO + IF( ABS1( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = CZERO GO TO 60 END IF END IF * - IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN - B( ILAST, ILAST ) = CZERO + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = CZERO GO TO 50 END IF * @@ -425,30 +450,30 @@ * DO 40 J = ILAST - 1, ILO, -1 * -* Test 1: for A(j,j-1)=0 or j=ILO +* Test 1: for H(j,j-1)=0 or j=ILO * IF( J.EQ.ILO ) THEN ILAZRO = .TRUE. ELSE - IF( ABS1( A( J, J-1 ) ).LE.ATOL ) THEN - A( J, J-1 ) = CZERO + IF( ABS1( H( J, J-1 ) ).LE.ATOL ) THEN + H( J, J-1 ) = CZERO ILAZRO = .TRUE. ELSE ILAZRO = .FALSE. END IF END IF * -* Test 2: for B(j,j)=0 +* Test 2: for T(j,j)=0 * - IF( ABS( B( J, J ) ).LT.BTOL ) THEN - B( J, J ) = CZERO + IF( ABS( T( J, J ) ).LT.BTOL ) THEN + T( J, J ) = CZERO * * Test 1a: Check for 2 consecutive small subdiagonals in A * ILAZR2 = .FALSE. IF( .NOT.ILAZRO ) THEN - IF( ABS1( A( J, J-1 ) )*( ASCALE*ABS1( A( J+1, - $ J ) ) ).LE.ABS1( A( J, J ) )*( ASCALE*ATOL ) ) + IF( ABS1( H( J, J-1 ) )*( ASCALE*ABS1( H( J+1, + $ J ) ) ).LE.ABS1( H( J, J ) )*( ASCALE*ATOL ) ) $ ILAZR2 = .TRUE. END IF * @@ -460,24 +485,24 @@ * IF( ILAZRO .OR. ILAZR2 ) THEN DO 20 JCH = J, ILAST - 1 - CTEMP = A( JCH, JCH ) - CALL ZLARTG( CTEMP, A( JCH+1, JCH ), C, S, - $ A( JCH, JCH ) ) - A( JCH+1, JCH ) = CZERO - CALL ZROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA, - $ A( JCH+1, JCH+1 ), LDA, C, S ) - CALL ZROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB, - $ B( JCH+1, JCH+1 ), LDB, C, S ) + CTEMP = H( JCH, JCH ) + CALL ZLARTG( CTEMP, H( JCH+1, JCH ), C, S, + $ H( JCH, JCH ) ) + H( JCH+1, JCH ) = CZERO + CALL ZROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH, + $ H( JCH+1, JCH+1 ), LDH, C, S ) + CALL ZROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT, + $ T( JCH+1, JCH+1 ), LDT, C, S ) IF( ILQ ) $ CALL ZROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, DCONJG( S ) ) IF( ILAZR2 ) - $ A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C + $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C ILAZR2 = .FALSE. * --------------- Begin Timing Code ----------------- OPST = OPST + DBLE( 32+40*( ILASTM-JCH )+20*NQ ) * ---------------- End Timing Code ------------------ - IF( ABS1( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN + IF( ABS1( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN IF( JCH+1.GE.ILAST ) THEN GO TO 60 ELSE @@ -485,35 +510,35 @@ GO TO 70 END IF END IF - B( JCH+1, JCH+1 ) = CZERO + T( JCH+1, JCH+1 ) = CZERO 20 CONTINUE GO TO 50 ELSE * -* Only test 2 passed -- chase the zero to B(ILAST,ILAST) -* Then process as in the case B(ILAST,ILAST)=0 +* Only test 2 passed -- chase the zero to T(ILAST,ILAST) +* Then process as in the case T(ILAST,ILAST)=0 * DO 30 JCH = J, ILAST - 1 - CTEMP = B( JCH, JCH+1 ) - CALL ZLARTG( CTEMP, B( JCH+1, JCH+1 ), C, S, - $ B( JCH, JCH+1 ) ) - B( JCH+1, JCH+1 ) = CZERO + CTEMP = T( JCH, JCH+1 ) + CALL ZLARTG( CTEMP, T( JCH+1, JCH+1 ), C, S, + $ T( JCH, JCH+1 ) ) + T( JCH+1, JCH+1 ) = CZERO IF( JCH.LT.ILASTM-1 ) - $ CALL ZROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB, - $ B( JCH+1, JCH+2 ), LDB, C, S ) - CALL ZROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA, - $ A( JCH+1, JCH-1 ), LDA, C, S ) + $ CALL ZROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT, + $ T( JCH+1, JCH+2 ), LDT, C, S ) + CALL ZROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH, + $ H( JCH+1, JCH-1 ), LDH, C, S ) IF( ILQ ) $ CALL ZROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, DCONJG( S ) ) - CTEMP = A( JCH+1, JCH ) - CALL ZLARTG( CTEMP, A( JCH+1, JCH-1 ), C, S, - $ A( JCH+1, JCH ) ) - A( JCH+1, JCH-1 ) = CZERO - CALL ZROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1, - $ A( IFRSTM, JCH-1 ), 1, C, S ) - CALL ZROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1, - $ B( IFRSTM, JCH-1 ), 1, C, S ) + CTEMP = H( JCH+1, JCH ) + CALL ZLARTG( CTEMP, H( JCH+1, JCH-1 ), C, S, + $ H( JCH+1, JCH ) ) + H( JCH+1, JCH-1 ) = CZERO + CALL ZROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1, + $ H( IFRSTM, JCH-1 ), 1, C, S ) + CALL ZROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1, + $ T( IFRSTM, JCH-1 ), 1, C, S ) IF( ILZ ) $ CALL ZROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, $ C, S ) @@ -543,40 +568,40 @@ INFO = 2*N + 1 GO TO 210 * -* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a +* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a * 1x1 block. * 50 CONTINUE - CTEMP = A( ILAST, ILAST ) - CALL ZLARTG( CTEMP, A( ILAST, ILAST-1 ), C, S, - $ A( ILAST, ILAST ) ) - A( ILAST, ILAST-1 ) = CZERO - CALL ZROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1, - $ A( IFRSTM, ILAST-1 ), 1, C, S ) - CALL ZROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1, - $ B( IFRSTM, ILAST-1 ), 1, C, S ) + CTEMP = H( ILAST, ILAST ) + CALL ZLARTG( CTEMP, H( ILAST, ILAST-1 ), C, S, + $ H( ILAST, ILAST ) ) + H( ILAST, ILAST-1 ) = CZERO + CALL ZROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1, + $ H( IFRSTM, ILAST-1 ), 1, C, S ) + CALL ZROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1, + $ T( IFRSTM, ILAST-1 ), 1, C, S ) IF( ILZ ) $ CALL ZROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S ) * --------------------- Begin Timing Code ----------------------- OPST = OPST + DBLE( 32+40*( ILAST-IFRSTM )+20*NZ ) * ---------------------- End Timing Code ------------------------ * -* A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA +* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA * 60 CONTINUE - ABSB = ABS( B( ILAST, ILAST ) ) + ABSB = ABS( T( ILAST, ILAST ) ) IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = DCONJG( B( ILAST, ILAST ) / ABSB ) - B( ILAST, ILAST ) = ABSB + SIGNBC = DCONJG( T( ILAST, ILAST ) / ABSB ) + T( ILAST, ILAST ) = ABSB IF( ILSCHR ) THEN - CALL ZSCAL( ILAST-IFRSTM, SIGNBC, B( IFRSTM, ILAST ), 1 ) - CALL ZSCAL( ILAST+1-IFRSTM, SIGNBC, A( IFRSTM, ILAST ), + CALL ZSCAL( ILAST-IFRSTM, SIGNBC, T( IFRSTM, ILAST ), 1 ) + CALL ZSCAL( ILAST+1-IFRSTM, SIGNBC, H( IFRSTM, ILAST ), $ 1 ) * ----------------- Begin Timing Code --------------------- OPST = OPST + DBLE( 12*( ILAST-IFRSTM ) ) * ------------------ End Timing Code ---------------------- ELSE - A( ILAST, ILAST ) = A( ILAST, ILAST )*SIGNBC + H( ILAST, ILAST ) = H( ILAST, ILAST )*SIGNBC END IF IF( ILZ ) $ CALL ZSCAL( N, SIGNBC, Z( 1, ILAST ), 1 ) @@ -584,10 +609,10 @@ OPST = OPST + DBLE( 6*NZ+13 ) * -------------------- End Timing Code ----------------------- ELSE - B( ILAST, ILAST ) = CZERO + T( ILAST, ILAST ) = CZERO END IF - ALPHA( ILAST ) = A( ILAST, ILAST ) - BETA( ILAST ) = B( ILAST, ILAST ) + ALPHA( ILAST ) = H( ILAST, ILAST ) + BETA( ILAST ) = T( ILAST, ILAST ) * * Go to next block -- exit if finished. * @@ -620,7 +645,7 @@ * Compute the Shift. * * At this point, IFIRST < ILAST, and the diagonal elements of -* B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in +* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in * magnitude) * IF( ( IITER / 10 )*10.NE.IITER ) THEN @@ -632,26 +657,26 @@ * We factor B as U*D, where U has unit diagonals, and * compute (A*inv(D))*inv(U). * - U12 = ( BSCALE*B( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) - AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) - AD22 = ( ASCALE*A( ILAST, ILAST ) ) / - $ ( BSCALE*B( ILAST, ILAST ) ) + U12 = ( BSCALE*T( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD22 = ( ASCALE*H( ILAST, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) ABI22 = AD22 - U12*AD21 * - T = HALF*( AD11+ABI22 ) - RTDISC = SQRT( T**2+AD12*AD21-AD11*AD22 ) - TEMP = DBLE( T-ABI22 )*DBLE( RTDISC ) + - $ DIMAG( T-ABI22 )*DIMAG( RTDISC ) + T1 = HALF*( AD11+ABI22 ) + RTDISC = SQRT( T1**2+AD12*AD21-AD11*AD22 ) + TEMP = DBLE( T1-ABI22 )*DBLE( RTDISC ) + + $ DIMAG( T1-ABI22 )*DIMAG( RTDISC ) IF( TEMP.LE.ZERO ) THEN - SHIFT = T + RTDISC + SHIFT = T1 + RTDISC ELSE - SHIFT = T - RTDISC + SHIFT = T1 - RTDISC END IF * * ------------------- Begin Timing Code ---------------------- @@ -662,8 +687,8 @@ * * Exceptional shift. Chosen for no particularly good reason. * - ESHIFT = ESHIFT + DCONJG( ( ASCALE*A( ILAST-1, ILAST ) ) / - $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) ) + ESHIFT = ESHIFT + DCONJG( ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) ) SHIFT = ESHIFT * * ------------------- Begin Timing Code ---------------------- @@ -676,21 +701,21 @@ * DO 80 J = ILAST - 1, IFIRST + 1, -1 ISTART = J - CTEMP = ASCALE*A( J, J ) - SHIFT*( BSCALE*B( J, J ) ) + CTEMP = ASCALE*H( J, J ) - SHIFT*( BSCALE*T( J, J ) ) TEMP = ABS1( CTEMP ) - TEMP2 = ASCALE*ABS1( A( J+1, J ) ) + TEMP2 = ASCALE*ABS1( H( J+1, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF - IF( ABS1( A( J, J-1 ) )*TEMP2.LE.TEMP*ATOL ) + IF( ABS1( H( J, J-1 ) )*TEMP2.LE.TEMP*ATOL ) $ GO TO 90 80 CONTINUE * ISTART = IFIRST - CTEMP = ASCALE*A( IFIRST, IFIRST ) - - $ SHIFT*( BSCALE*B( IFIRST, IFIRST ) ) + CTEMP = ASCALE*H( IFIRST, IFIRST ) - + $ SHIFT*( BSCALE*T( IFIRST, IFIRST ) ) * * --------------------- Begin Timing Code ----------------------- OPST = OPST - DBLE( 6 ) @@ -702,7 +727,7 @@ * * Initial Q * - CTEMP2 = ASCALE*A( ISTART+1, ISTART ) + CTEMP2 = ASCALE*H( ISTART+1, ISTART ) * * --------------------- Begin Timing Code ----------------------- OPST = OPST + DBLE( 2+( ILAST-ISTART )*18 ) @@ -714,18 +739,18 @@ * DO 150 J = ISTART, ILAST - 1 IF( J.GT.ISTART ) THEN - CTEMP = A( J, J-1 ) - CALL ZLARTG( CTEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) - A( J+1, J-1 ) = CZERO + CTEMP = H( J, J-1 ) + CALL ZLARTG( CTEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = CZERO END IF * DO 100 JC = J, ILASTM - CTEMP = C*A( J, JC ) + S*A( J+1, JC ) - A( J+1, JC ) = -DCONJG( S )*A( J, JC ) + C*A( J+1, JC ) - A( J, JC ) = CTEMP - CTEMP2 = C*B( J, JC ) + S*B( J+1, JC ) - B( J+1, JC ) = -DCONJG( S )*B( J, JC ) + C*B( J+1, JC ) - B( J, JC ) = CTEMP2 + CTEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -DCONJG( S )*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = CTEMP + CTEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -DCONJG( S )*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = CTEMP2 100 CONTINUE IF( ILQ ) THEN DO 110 JR = 1, N @@ -735,19 +760,19 @@ 110 CONTINUE END IF * - CTEMP = B( J+1, J+1 ) - CALL ZLARTG( CTEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) - B( J+1, J ) = CZERO + CTEMP = T( J+1, J+1 ) + CALL ZLARTG( CTEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = CZERO * DO 120 JR = IFRSTM, MIN( J+2, ILAST ) - CTEMP = C*A( JR, J+1 ) + S*A( JR, J ) - A( JR, J ) = -DCONJG( S )*A( JR, J+1 ) + C*A( JR, J ) - A( JR, J+1 ) = CTEMP + CTEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -DCONJG( S )*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = CTEMP 120 CONTINUE DO 130 JR = IFRSTM, J - CTEMP = C*B( JR, J+1 ) + S*B( JR, J ) - B( JR, J ) = -DCONJG( S )*B( JR, J+1 ) + C*B( JR, J ) - B( JR, J+1 ) = CTEMP + CTEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -DCONJG( S )*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = CTEMP 130 CONTINUE IF( ILZ ) THEN DO 140 JR = 1, N @@ -793,18 +818,18 @@ * Set Eigenvalues 1:ILO-1 * DO 200 J = 1, ILO - 1 - ABSB = ABS( B( J, J ) ) + ABSB = ABS( T( J, J ) ) IF( ABSB.GT.SAFMIN ) THEN - SIGNBC = DCONJG( B( J, J ) / ABSB ) - B( J, J ) = ABSB + SIGNBC = DCONJG( T( J, J ) / ABSB ) + T( J, J ) = ABSB IF( ILSCHR ) THEN - CALL ZSCAL( J-1, SIGNBC, B( 1, J ), 1 ) - CALL ZSCAL( J, SIGNBC, A( 1, J ), 1 ) + CALL ZSCAL( J-1, SIGNBC, T( 1, J ), 1 ) + CALL ZSCAL( J, SIGNBC, H( 1, J ), 1 ) * ----------------- Begin Timing Code --------------------- OPST = OPST + DBLE( 12*( J-1 ) ) * ------------------ End Timing Code ---------------------- ELSE - A( J, J ) = A( J, J )*SIGNBC + H( J, J ) = H( J, J )*SIGNBC END IF IF( ILZ ) $ CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 ) @@ -812,10 +837,10 @@ OPST = OPST + DBLE( 6*NZ+13 ) * -------------------- End Timing Code ----------------------- ELSE - B( J, J ) = CZERO + T( J, J ) = CZERO END IF - ALPHA( J ) = A( J, J ) - BETA( J ) = B( J, J ) + ALPHA( J ) = H( J, J ) + BETA( J ) = T( J, J ) 200 CONTINUE * * Normal Termination diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/ztgevc.f LAPACK/TIMING/EIG/EIGSRC/ztgevc.f --- LAPACK.orig/TIMING/EIG/EIGSRC/ztgevc.f Thu Nov 4 14:28:33 1999 +++ LAPACK/TIMING/EIG/EIGSRC/ztgevc.f Fri May 25 16:20:52 2001 @@ -1,19 +1,19 @@ - SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, + SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO ) * * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 4, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE - INTEGER INFO, LDA, LDB, LDVL, LDVR, M, MM, N + INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) DOUBLE PRECISION RWORK( * ) - COMPLEX*16 A( LDA, * ), B( LDB, * ), VL( LDVL, * ), + COMPLEX*16 P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * @@ -34,28 +34,30 @@ * Purpose * ======= * -* ZTGEVC computes some or all of the right and/or left generalized -* eigenvectors of a pair of complex upper triangular matrices (A,B). -* -* The right generalized eigenvector x and the left generalized -* eigenvector y of (A,B) corresponding to a generalized eigenvalue -* w are defined by: -* -* (A - wB) * x = 0 and y**H * (A - wB) = 0 -* +* ZTGEVC computes some or all of the right and/or left eigenvectors of +* a pair of complex matrices (S,P), where S and P are upper triangular. +* Matrix pairs of this type are produced by the generalized Schur +* factorization of a complex matrix pair (A,B): +* +* A = Q*S*Z**H, B = Q*P*Z**H +* +* as computed by ZGGHRD + ZHGEQZ. +* +* The right eigenvector x and the left eigenvector y of (S,P) +* corresponding to an eigenvalue w are defined by: +* +* S*x = w*P*x, (y**H)*S = w*(y**H)*P, +* * where y**H denotes the conjugate tranpose of y. -* -* If an eigenvalue w is determined by zero diagonal elements of both A -* and B, a unit vector is returned as the corresponding eigenvector. -* -* If all eigenvectors are requested, the routine may either return -* the matrices X and/or Y of right or left eigenvectors of (A,B), or -* the products Z*X and/or Q*Y, where Z and Q are input unitary -* matrices. If (A,B) was obtained from the generalized Schur -* factorization of an original pair of matrices -* (A0,B0) = (Q*A*Z**H,Q*B*Z**H), -* then Z*X and Q*Y are the matrices of right or left eigenvectors of -* A. +* The eigenvalues are not input to this routine, but are computed +* directly from the diagonal elements of S and P. +* +* This routine returns the matrices X and/or Y of right and left +* eigenvectors of (S,P), or the products Z*X and/or Q*Y, +* where Z and Q are input matrices. +* If Q and Z are the unitary factors from the generalized Schur +* factorization of a matrix pair (A,B), then Z*X and Q*Y +* are the matrices of right and left eigenvectors of (A,B). * * Arguments * ========= @@ -67,70 +69,69 @@ * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; -* = 'B': compute all right and/or left eigenvectors, and -* backtransform them using the input matrices supplied -* in VR and/or VL; +* = 'B': compute all right and/or left eigenvectors, +* backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY='S', SELECT specifies the eigenvectors to be -* computed. -* If HOWMNY='A' or 'B', SELECT is not referenced. -* To select the eigenvector corresponding to the j-th -* eigenvalue, SELECT(j) must be set to .TRUE.. +* 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 matrices A and B. N >= 0. -* -* A (input) COMPLEX*16 array, dimension (LDA,N) -* The upper triangular matrix A. -* -* LDA (input) INTEGER -* The leading dimension of array A. LDA >= max(1,N). +* The order of the matrices S and P. N >= 0. * -* B (input) COMPLEX*16 array, dimension (LDB,N) -* The upper triangular matrix B. B must have real diagonal -* elements. +* S (input) COMPLEX*16 array, dimension (LDS,N) +* The upper triangular matrix S from a generalized Schur +* factorization, as computed by ZHGEQZ. +* +* LDS (input) INTEGER +* The leading dimension of array S. LDS >= max(1,N). +* +* P (input) COMPLEX*16 array, dimension (LDP,N) +* The upper triangular matrix P from a generalized Schur +* factorization, as computed by ZHGEQZ. P must have real +* diagonal elements. * -* LDB (input) INTEGER -* The leading dimension of array B. LDB >= max(1,N). +* LDP (input) INTEGER +* The leading dimension of array P. LDP >= 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 left Schur vectors returned by ZHGEQZ). * On exit, if SIDE = 'L' or 'B', VL contains: -* if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Q*Y; -* if HOWMNY = 'S', the left eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VL, in the same order as their eigenvalues. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of array VL. -* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* The leading dimension of array VL. LDVL >= 1, and if +* SIDE = 'L' or 'l' or 'B' 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 Z * of right Schur vectors returned by ZHGEQZ). * On exit, if SIDE = 'R' or 'B', VR contains: -* if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); +* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Z*X; -* if HOWMNY = 'S', the right eigenvectors of (A,B) specified by +* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VR, in the same order as their eigenvalues. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. -* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* The leading dimension of the array VR. LDVR >= 1, and if +* SIDE = 'R' or 'B', LDVR >= N. * * MM (input) INTEGER -* The leading dimension of the array VR. -* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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 @@ -194,7 +195,7 @@ IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. - ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN + ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. @@ -225,9 +226,9 @@ INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN @@ -251,7 +252,7 @@ * ILBBAD = .FALSE. DO 20 J = 1, N - IF( DIMAG( B( J, J ) ).NE.ZERO ) + IF( DIMAG( P( J, J ) ).NE.ZERO ) $ ILBBAD = .TRUE. 20 CONTINUE * @@ -289,19 +290,19 @@ * part of A and B to check for possible overflow in the triangular * solver. * - ANORM = ABS1( A( 1, 1 ) ) - BNORM = ABS1( B( 1, 1 ) ) + ANORM = ABS1( S( 1, 1 ) ) + BNORM = ABS1( P( 1, 1 ) ) RWORK( 1 ) = ZERO RWORK( N+1 ) = ZERO DO 40 J = 2, N RWORK( J ) = ZERO RWORK( N+J ) = ZERO DO 30 I = 1, J - 1 - RWORK( J ) = RWORK( J ) + ABS1( A( I, J ) ) - RWORK( N+J ) = RWORK( N+J ) + ABS1( B( I, J ) ) + RWORK( J ) = RWORK( J ) + ABS1( S( I, J ) ) + RWORK( N+J ) = RWORK( N+J ) + ABS1( P( I, J ) ) 30 CONTINUE - ANORM = MAX( ANORM, RWORK( J )+ABS1( A( J, J ) ) ) - BNORM = MAX( BNORM, RWORK( N+J )+ABS1( B( J, J ) ) ) + ANORM = MAX( ANORM, RWORK( J )+ABS1( S( J, J ) ) ) + BNORM = MAX( BNORM, RWORK( N+J )+ABS1( P( J, J ) ) ) 40 CONTINUE * ASCALE = ONE / MAX( ANORM, SAFMIN ) @@ -326,8 +327,8 @@ IF( ILCOMP ) THEN IEIG = IEIG + 1 * - IF( ABS1( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( DBLE( B( JE, JE ) ) ).LE.SAFMIN ) THEN + IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * @@ -343,10 +344,10 @@ * H * y ( a A - b B ) = 0 * - TEMP = ONE / MAX( ABS1( A( JE, JE ) )*ASCALE, - $ ABS( DBLE( B( JE, JE ) ) )*BSCALE, SAFMIN ) - SALPHA = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*DBLE( B( JE, JE ) ) )*BSCALE + TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, + $ ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN ) + SALPHA = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * @@ -403,7 +404,7 @@ * * Compute * j-1 -* SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) +* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * (Scale if necessary) * @@ -422,16 +423,16 @@ SUMB = CZERO * DO 80 JR = JE, J - 1 - SUMA = SUMA + DCONJG( A( JR, J ) )*WORK( JR ) - SUMB = SUMB + DCONJG( B( JR, J ) )*WORK( JR ) + SUMA = SUMA + DCONJG( S( JR, J ) )*WORK( JR ) + SUMB = SUMB + DCONJG( P( JR, J ) )*WORK( JR ) 80 CONTINUE SUM = ACOEFF*SUMA - DCONJG( BCOEFF )*SUMB * -* Form x(j) = - SUM / conjg( a*A(j,j) - b*B(j,j) ) +* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) * * with scaling and perturbation of the denominator * - D = DCONJG( ACOEFF*A( J, J )-BCOEFF*B( J, J ) ) + D = DCONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) ) IF( ABS1( D ).LE.DMIN ) $ D = DCMPLX( DMIN ) * @@ -511,8 +512,8 @@ IF( ILCOMP ) THEN IEIG = IEIG - 1 * - IF( ABS1( A( JE, JE ) ).LE.SAFMIN .AND. - $ ABS( DBLE( B( JE, JE ) ) ).LE.SAFMIN ) THEN + IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND. + $ ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * @@ -528,10 +529,10 @@ * * ( a A - b B ) x = 0 * - TEMP = ONE / MAX( ABS1( A( JE, JE ) )*ASCALE, - $ ABS( DBLE( B( JE, JE ) ) )*BSCALE, SAFMIN ) - SALPHA = ( TEMP*A( JE, JE ) )*ASCALE - SBETA = ( TEMP*DBLE( B( JE, JE ) ) )*BSCALE + TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE, + $ ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN ) + SALPHA = ( TEMP*S( JE, JE ) )*ASCALE + SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * @@ -584,7 +585,7 @@ * WORK(j+1:JE) contains x * DO 170 JR = 1, JE - 1 - WORK( JR ) = ACOEFF*A( JR, JE ) - BCOEFF*B( JR, JE ) + WORK( JR ) = ACOEFF*S( JR, JE ) - BCOEFF*P( JR, JE ) 170 CONTINUE WORK( JE ) = CONE * @@ -593,7 +594,7 @@ * Form x(j) := - w(j) / d * with scaling and perturbation of the denominator * - D = ACOEFF*A( J, J ) - BCOEFF*B( J, J ) + D = ACOEFF*S( J, J ) - BCOEFF*P( J, J ) IF( ABS1( D ).LE.DMIN ) $ D = DCMPLX( DMIN ) * @@ -615,7 +616,7 @@ * IF( J.GT.1 ) THEN * -* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling +* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( ABS1( WORK( J ) ).GT.ONE ) THEN TEMP = ONE / ABS1( WORK( J ) ) @@ -635,8 +636,8 @@ CA = ACOEFF*WORK( J ) CB = BCOEFF*WORK( J ) DO 200 JR = 1, J - 1 - WORK( JR ) = WORK( JR ) + CA*A( JR, J ) - - $ CB*B( JR, J ) + WORK( JR ) = WORK( JR ) + CA*S( JR, J ) - + $ CB*P( JR, J ) 200 CONTINUE END IF 210 CONTINUE diff -uNr LAPACK.orig/TIMING/EIG/EIGSRC/ztrevc.f LAPACK/TIMING/EIG/EIGSRC/ztrevc.f --- LAPACK.orig/TIMING/EIG/EIGSRC/ztrevc.f Thu Nov 4 14:28:34 1999 +++ LAPACK/TIMING/EIG/EIGSRC/ztrevc.f Fri May 25 16:21:10 2001 @@ -4,7 +4,7 @@ * -- LAPACK routine (instrumented to count operations, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 +* May 7, 2001 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE @@ -31,20 +31,23 @@ * * 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'*T = w*y' -* -* where y' denotes the conjugate transpose of the vector y. -* -* If all eigenvectors are requested, the routine may either return the -* matrices X and/or Y of right or left eigenvectors of T, or the -* products Q*X and/or Q*Y, where Q is an input unitary -* matrix. If T was obtained from the Schur factorization of an -* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of -* right or left eigenvectors of A. +* +* T*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 * ========= @@ -57,17 +60,17 @@ * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, -* and backtransform them using the input matrices -* supplied in VR and/or VL; +* backtransformed using the matrices supplied in +* VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, -* specified by the logical array SELECT. +* as indicated by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. -* If HOWMNY = 'A' or 'B', SELECT is not referenced. -* To select the eigenvector corresponding to the j-th -* eigenvalue, SELECT(j) must be set to .TRUE.. +* 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. @@ -85,19 +88,16 @@ * 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; -* VL is lower triangular. The i-th column -* VL(i) of VL is the eigenvector corresponding -* to T(i,i). * 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. -* If SIDE = 'R', VL is not referenced. +* Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER -* The leading dimension of the array VL. LDVL >= max(1,N) if -* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. +* 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 @@ -105,19 +105,16 @@ * 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; -* VR is upper triangular. The i-th column -* VR(i) of VR is the eigenvector corresponding -* to T(i,i). * 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. -* If SIDE = 'L', VR is not referenced. +* Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER -* The leading dimension of the array VR. LDVR >= max(1,N) if -* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. +* 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. diff -uNr LAPACK.orig/TIMING/LIN/LINSRC/cgelss.f LAPACK/TIMING/LIN/LINSRC/cgelss.f --- LAPACK.orig/TIMING/LIN/LINSRC/cgelss.f Thu Nov 4 14:28:16 1999 +++ LAPACK/TIMING/LIN/LINSRC/cgelss.f Fri May 25 16:21:43 2001 @@ -4,7 +4,7 @@ * -- LAPACK driver routine (instrumented to count ops, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -98,10 +98,9 @@ * LWORK >= 2*min(M,N) + max(M,N,NRHS) * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) REAL array, dimension (5*min(M,N)) * @@ -187,7 +186,7 @@ * immediately following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 0 MM = M IF( M.GE.N .AND. M.GE.MNTHR ) THEN @@ -255,13 +254,12 @@ MAXWRK = MAX( MAXWRK, N*NRHS ) END IF END IF - MINWRK = MAX( MINWRK, 1 ) MAXWRK = MAX( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGELSS', -INFO ) RETURN @@ -632,10 +630,10 @@ $ SOPBL3( 'CGEMM ', M, BL, M ) T1 = SECOND( ) CALL CGEMM( 'C', 'N', M, BL, M, CONE, WORK( IL ), LDWORK, - $ B( 1, I ), LDB, CZERO, WORK( IWORK ), N ) + $ B( 1, I ), LDB, CZERO, WORK( IWORK ), M ) T2 = SECOND( ) TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 ) - CALL CLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ), + CALL CLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), $ LDB ) 40 CONTINUE ELSE diff -uNr LAPACK.orig/TIMING/LIN/LINSRC/dgelss.f LAPACK/TIMING/LIN/LINSRC/dgelss.f --- LAPACK.orig/TIMING/LIN/LINSRC/dgelss.f Thu Nov 4 14:28:17 1999 +++ LAPACK/TIMING/LIN/LINSRC/dgelss.f Fri May 25 16:21:40 2001 @@ -4,7 +4,7 @@ * -- LAPACK driver routine (instrumented to count ops, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -97,10 +97,9 @@ * LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * INFO (output) INTEGER * = 0: successful exit @@ -178,7 +177,7 @@ * following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 0 MM = M IF( M.GE.N .AND. M.GE.MNTHR ) THEN @@ -251,11 +250,10 @@ END IF MAXWRK = MAX( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 END IF * - MINWRK = MAX( MINWRK, 1 ) - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELSS', -INFO ) RETURN @@ -613,10 +611,10 @@ $ DOPBL3( 'DGEMM ', M, BL, M ) T1 = DSECND( ) CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, - $ B( 1, I ), LDB, ZERO, WORK( IWORK ), N ) + $ B( 1, I ), LDB, ZERO, WORK( IWORK ), M ) T2 = DSECND( ) TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 ) - CALL DLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ), + CALL DLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), $ LDB ) 40 CONTINUE ELSE diff -uNr LAPACK.orig/TIMING/LIN/LINSRC/sgelss.f LAPACK/TIMING/LIN/LINSRC/sgelss.f --- LAPACK.orig/TIMING/LIN/LINSRC/sgelss.f Thu Nov 4 14:28:18 1999 +++ LAPACK/TIMING/LIN/LINSRC/sgelss.f Fri May 25 16:21:36 2001 @@ -4,7 +4,7 @@ * -- LAPACK driver routine (instrumented to count ops, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -97,10 +97,9 @@ * LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * INFO (output) INTEGER * = 0: successful exit @@ -178,7 +177,7 @@ * following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 0 MM = M IF( M.GE.N .AND. M.GE.MNTHR ) THEN @@ -251,11 +250,10 @@ END IF MAXWRK = MAX( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 END IF * - MINWRK = MAX( MINWRK, 1 ) - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGELSS', -INFO ) RETURN @@ -613,10 +611,10 @@ $ SOPBL3( 'SGEMM ', M, BL, M ) T1 = SECOND( ) CALL SGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, - $ B( 1, I ), LDB, ZERO, WORK( IWORK ), N ) + $ B( 1, I ), LDB, ZERO, WORK( IWORK ), M ) T2 = SECOND( ) TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 ) - CALL SLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ), + CALL SLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), $ LDB ) 40 CONTINUE ELSE diff -uNr LAPACK.orig/TIMING/LIN/LINSRC/zgelss.f LAPACK/TIMING/LIN/LINSRC/zgelss.f --- LAPACK.orig/TIMING/LIN/LINSRC/zgelss.f Thu Nov 4 14:28:18 1999 +++ LAPACK/TIMING/LIN/LINSRC/zgelss.f Fri May 25 16:21:47 2001 @@ -4,7 +4,7 @@ * -- LAPACK driver routine (instrumented to count ops, version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University -* October 31, 1999 +* April 25, 2001 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK @@ -98,10 +98,9 @@ * LWORK >= 2*min(M,N) + max(M,N,NRHS) * For good performance, LWORK should generally be larger. * -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. +* If LWORK = -1, a workspace query is assumed. The optimal +* size for the WORK array is calculated and stored in WORK(1), +* and no other work except argument checking is performed. * * RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)) * @@ -186,7 +185,7 @@ * immediately following subroutine, as returned by ILAENV.) * MINWRK = 1 - IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN + IF( INFO.EQ.0 ) THEN MAXWRK = 0 MM = M IF( M.GE.N .AND. M.GE.MNTHR ) THEN @@ -254,13 +253,12 @@ MAXWRK = MAX( MAXWRK, N*NRHS ) END IF END IF - MINWRK = MAX( MINWRK, 1 ) MAXWRK = MAX( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELSS', -INFO ) RETURN @@ -631,10 +629,10 @@ $ DOPBL3( 'ZGEMM ', M, BL, M ) T1 = DSECND( ) CALL ZGEMM( 'C', 'N', M, BL, M, CONE, WORK( IL ), LDWORK, - $ B( 1, I ), LDB, CZERO, WORK( IWORK ), N ) + $ B( 1, I ), LDB, CZERO, WORK( IWORK ), M ) T2 = DSECND( ) TIMNG( GEMM ) = TIMNG( GEMM ) + ( T2-T1 ) - CALL ZLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ), + CALL ZLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), $ LDB ) 40 CONTINUE ELSE diff -uNr LAPACK.orig/TIMING/Makefile LAPACK/TIMING/Makefile --- LAPACK.orig/TIMING/Makefile Thu Nov 4 14:27:54 1999 +++ LAPACK/TIMING/Makefile Fri May 25 16:17:35 2001 @@ -141,242 +141,242 @@ stime.out: stime.in xlintims @echo Timing square REAL LAPACK linear equation routines - xlintims < stime.in > $@ 2>&1 + ./xlintims < stime.in > $@ 2>&1 STIME.out: STIME.in xlintims @echo Timing square REAL LAPACK linear equation routines - xlintims < STIME.in > $@ 2>&1 + ./xlintims < STIME.in > $@ 2>&1 sband.out: sband.in xlintims @echo Timing banded REAL LAPACK linear equation routines - xlintims < sband.in > $@ 2>&1 + ./xlintims < sband.in > $@ 2>&1 SBAND.out: SBAND.in xlintims @echo Timing banded REAL LAPACK linear equation routines - xlintims < SBAND.in > $@ 2>&1 + ./xlintims < SBAND.in > $@ 2>&1 stime2.out: stime2.in xlintims @echo Timing rectangular REAL LAPACK linear equation routines - xlintims < stime2.in > $@ 2>&1 + ./xlintims < stime2.in > $@ 2>&1 STIME2.out: STIME2.in xlintims @echo Timing rectangular REAL LAPACK linear equation routines - xlintims < STIME2.in > $@ 2>&1 + ./xlintims < STIME2.in > $@ 2>&1 # # ======== COMPLEX LIN TIMINGS ========================== ctime.out: ctime.in xlintimc @echo Timing square COMPLEX LAPACK linear equation routines - xlintimc < ctime.in > $@ 2>&1 + ./xlintimc < ctime.in > $@ 2>&1 CTIME.out: CTIME.in xlintimc @echo Timing square COMPLEX LAPACK linear equation routines - xlintimc < CTIME.in > $@ 2>&1 + ./xlintimc < CTIME.in > $@ 2>&1 cband.out: cband.in xlintimc @echo Timing banded COMPLEX LAPACK linear equation routines - xlintimc < cband.in > $@ 2>&1 + ./xlintimc < cband.in > $@ 2>&1 CBAND.out: CBAND.in xlintimc @echo Timing banded COMPLEX LAPACK linear equation routines - xlintimc < CBAND.in > $@ 2>&1 + ./xlintimc < CBAND.in > $@ 2>&1 ctime2.out: ctime2.in xlintimc @echo Timing rectangular COMPLEX LAPACK linear equation routines - xlintimc < ctime2.in > $@ 2>&1 + ./xlintimc < ctime2.in > $@ 2>&1 CTIME2.out: CTIME2.in xlintimc @echo Timing rectangular COMPLEX LAPACK linear equation routines - xlintimc < CTIME2.in > $@ 2>&1 + ./xlintimc < CTIME2.in > $@ 2>&1 # # ======== DOUBLE LIN TIMINGS =========================== dtime.out: dtime.in xlintimd @echo Timing square DOUBLE PRECISION LAPACK linear equation routines - xlintimd < dtime.in > $@ 2>&1 + ./xlintimd < dtime.in > $@ 2>&1 DTIME.out: DTIME.in xlintimd @echo Timing square DOUBLE PRECISION LAPACK linear equation routines - xlintimd < DTIME.in > $@ 2>&1 + ./xlintimd < DTIME.in > $@ 2>&1 dband.out: dband.in xlintimd @echo Timing banded DOUBLE PRECISION LAPACK linear equation routines - xlintimd < dband.in > $@ 2>&1 + ./xlintimd < dband.in > $@ 2>&1 DBAND.out: dband.in xlintimd @echo Timing banded DOUBLE PRECISION LAPACK linear equation routines - xlintimd < DBAND.in > $@ 2>&1 + ./xlintimd < DBAND.in > $@ 2>&1 dtime2.out: dtime2.in xlintimd @echo Timing rectangular DOUBLE PRECISION LAPACK linear equation routines - xlintimd < dtime2.in > $@ 2>&1 + ./xlintimd < dtime2.in > $@ 2>&1 DTIME2.out: DTIME2.in xlintimd @echo Timing rectangular DOUBLE PRECISION LAPACK linear equation routines - xlintimd < DTIME2.in > $@ 2>&1 + ./xlintimd < DTIME2.in > $@ 2>&1 # # ======== COMPLEX16 LIN TIMINGS ======================== ztime.out: ztime.in xlintimz @echo Timing square COMPLEX16 LAPACK linear equation routines - xlintimz < ztime.in > $@ 2>&1 + ./xlintimz < ztime.in > $@ 2>&1 ZTIME.out: ztime.in xlintimz @echo Timing square COMPLEX16 LAPACK linear equation routines - xlintimz < ZTIME.in > $@ 2>&1 + ./xlintimz < ZTIME.in > $@ 2>&1 zband.out: zband.in xlintimz @echo Timing banded COMPLEX16 LAPACK linear equation routines - xlintimz < zband.in > $@ 2>&1 + ./xlintimz < zband.in > $@ 2>&1 ZBAND.out: ZBAND.in xlintimz @echo Timing banded COMPLEX16 LAPACK linear equation routines - xlintimz < ZBAND.in > $@ 2>&1 + ./xlintimz < ZBAND.in > $@ 2>&1 ztime2.out: ztime2.in xlintimz @echo Timing rectangular COMPLEX16 LAPACK linear equation routines - xlintimz < ztime2.in > $@ 2>&1 + ./xlintimz < ztime2.in > $@ 2>&1 ZTIME2.out: ZTIME2.in xlintimz @echo Timing rectangular COMPLEX16 LAPACK linear equation routines - xlintimz < ZTIME2.in > $@ 2>&1 + ./xlintimz < ZTIME2.in > $@ 2>&1 # # # ======== SINGLE EIG TIMINGS =========================== # sgeptim.out: sgeptim.in xeigtims @echo GEP: Timing REAL Generalized Nonsymmetric Eigenvalue Problem routines - xeigtims < sgeptim.in > $@ 2>&1 + ./xeigtims < sgeptim.in > $@ 2>&1 SGEPTIM.out: SGEPTIM.in xeigtims @echo GEP: Timing REAL Generalized Nonsymmetric Eigenvalue Problem routines - xeigtims < SGEPTIM.in > $@ 2>&1 + ./xeigtims < SGEPTIM.in > $@ 2>&1 sneptim.out: sneptim.in xeigtims @echo NEP: Timing REAL Nonsymmetric Eigenvalue Problem routines - xeigtims < sneptim.in > $@ 2>&1 + ./xeigtims < sneptim.in > $@ 2>&1 SNEPTIM.out: SNEPTIM.in xeigtims @echo NEP: Timing REAL Nonsymmetric Eigenvalue Problem routines - xeigtims < SNEPTIM.in > $@ 2>&1 + ./xeigtims < SNEPTIM.in > $@ 2>&1 sseptim.out: sseptim.in xeigtims @echo SEP: Timing REAL Symmetric Eigenvalue Problem routines - xeigtims < sseptim.in > $@ 2>&1 + ./xeigtims < sseptim.in > $@ 2>&1 SSEPTIM.out: SSEPTIM.in xeigtims @echo SEP: Timing REAL Symmetric Eigenvalue Problem routines - xeigtims < SSEPTIM.in > $@ 2>&1 + ./xeigtims < SSEPTIM.in > $@ 2>&1 ssvdtim.out: ssvdtim.in xeigtims @echo SVD: Timing REAL Singular Value Decomposition routines - xeigtims < ssvdtim.in > $@ 2>&1 + ./xeigtims < ssvdtim.in > $@ 2>&1 SSVDTIM.out: SSVDTIM.in xeigtims @echo SVD: Timing REAL Singular Value Decomposition routines - xeigtims < SSVDTIM.in > $@ 2>&1 + ./xeigtims < SSVDTIM.in > $@ 2>&1 # # ======== COMPLEX EIG TIMINGS =========================== # cgeptim.out: cgeptim.in xeigtimc @echo GEP: Timing COMPLEX Generalized Nonsymmetric Eigenvalue Problem routines - xeigtimc < cgeptim.in > $@ 2>&1 + ./xeigtimc < cgeptim.in > $@ 2>&1 CGEPTIM.out: CGEPTIM.in xeigtimc @echo GEP: Timing COMPLEX Generalized Nonsymmetric Eigenvalue Problem routines - xeigtimc < cgeptim.in > $@ 2>&1 + ./xeigtimc < cgeptim.in > $@ 2>&1 cneptim.out: cneptim.in xeigtimc @echo NEP: Timing COMPLEX Nonsymmetric Eigenvalue Problem routines - xeigtimc < cneptim.in > $@ 2>&1 + ./xeigtimc < cneptim.in > $@ 2>&1 CNEPTIM.out: CNEPTIM.in xeigtimc @echo NEP: Timing COMPLEX Nonsymmetric Eigenvalue Problem routines - xeigtimc < CNEPTIM.in > $@ 2>&1 + ./xeigtimc < CNEPTIM.in > $@ 2>&1 cseptim.out: cseptim.in xeigtimc @echo SEP: Timing COMPLEX Symmetric Eigenvalue Problem routines - xeigtimc < cseptim.in > $@ 2>&1 + ./xeigtimc < cseptim.in > $@ 2>&1 CSEPTIM.out: CSEPTIM.in xeigtimc @echo SEP: Timing COMPLEX Symmetric Eigenvalue Problem routines - xeigtimc < CSEPTIM.in > $@ 2>&1 + ./xeigtimc < CSEPTIM.in > $@ 2>&1 csvdtim.out: csvdtim.in xeigtimc @echo SVD: Timing COMPLEX Singular Value Decomposition routines - xeigtimc < csvdtim.in > $@ 2>&1 + ./xeigtimc < csvdtim.in > $@ 2>&1 CSVDTIM.out: CSVDTIM.in xeigtimc @echo SVD: Timing COMPLEX Singular Value Decomposition routines - xeigtimc < CSVDTIM.in > $@ 2>&1 + ./xeigtimc < CSVDTIM.in > $@ 2>&1 # # ======== DOUBLE EIG TIMINGS =========================== # dgeptim.out: dgeptim.in xeigtimd @echo GEP: Timing DOUBLE PRECISION Generalized Nonsymmetric Eigenvalue Problem routines - xeigtimd < dgeptim.in > $@ 2>&1 + ./xeigtimd < dgeptim.in > $@ 2>&1 DGEPTIM.out: DGEPTIM.in xeigtimd @echo GEP: Timing DOUBLE PRECISION Generalized Nonsymmetric Eigenvalue Problem routines - xeigtimd < dgeptim.in > $@ 2>&1 + ./xeigtimd < dgeptim.in > $@ 2>&1 dneptim.out: dneptim.in xeigtimd @echo NEP: Timing DOUBLE PRECISION Nonsymmetric Eigenvalue Problem routines - xeigtimd < dneptim.in > $@ 2>&1 + ./xeigtimd < dneptim.in > $@ 2>&1 DNEPTIM.out: DNEPTIM.in xeigtimd @echo NEP: Timing DOUBLE PRECISION Nonsymmetric Eigenvalue Problem routines - xeigtimd < DNEPTIM.in > $@ 2>&1 + ./xeigtimd < DNEPTIM.in > $@ 2>&1 dseptim.out: dseptim.in xeigtimd @echo SEP: Timing DOUBLE PRECISION Symmetric Eigenvalue Problem routines - xeigtimd < dseptim.in > $@ 2>&1 + ./xeigtimd < dseptim.in > $@ 2>&1 DSEPTIM.out: DSEPTIM.in xeigtimd @echo SEP: Timing DOUBLE PRECISION Symmetric Eigenvalue Problem routines - xeigtimd < DSEPTIM.in > $@ 2>&1 + ./xeigtimd < DSEPTIM.in > $@ 2>&1 dsvdtim.out: dsvdtim.in xeigtimd @echo SVD: Timing DOUBLE PRECISION Singular Value Decomposition routines - xeigtimd < dsvdtim.in > $@ 2>&1 + ./xeigtimd < dsvdtim.in > $@ 2>&1 DSVDTIM.out: DSVDTIM.in xeigtimd @echo SVD: Timing DOUBLE PRECISION Singular Value Decomposition routines - xeigtimd < DSVDTIM.in > $@ 2>&1 + ./xeigtimd < DSVDTIM.in > $@ 2>&1 # # ======== COMPLEX16 EIG TIMINGS =========================== # zgeptim.out: zgeptim.in xeigtimz @echo GEP: Timing COMPLEX16 Generalized Nonsymmetric Eigenvalue Problem routines - xeigtimz < zgeptim.in > $@ 2>&1 + ./xeigtimz < zgeptim.in > $@ 2>&1 ZGEPTIM.out: ZGEPTIM.in xeigtimz @echo GEP: Timing COMPLEX16 Generalized Nonsymmetric Eigenvalue Problem routines - xeigtimz < zgeptim.in > $@ 2>&1 + ./xeigtimz < zgeptim.in > $@ 2>&1 zneptim.out: zneptim.in xeigtimz @echo NEP: Timing COMPLEX16 Nonsymmetric Eigenvalue Problem routines - xeigtimz < zneptim.in > $@ 2>&1 + ./xeigtimz < zneptim.in > $@ 2>&1 ZNEPTIM.out: ZNEPTIM.in xeigtimz @echo NEP: Timing COMPLEX16 Nonsymmetric Eigenvalue Problem routines - xeigtimz < ZNEPTIM.in > $@ 2>&1 + ./xeigtimz < ZNEPTIM.in > $@ 2>&1 zseptim.out: zseptim.in xeigtimz @echo SEP: Timing COMPLEX16 Symmetric Eigenvalue Problem routines - xeigtimz < zseptim.in > $@ 2>&1 + ./xeigtimz < zseptim.in > $@ 2>&1 ZSEPTIM.out: ZSEPTIM.in xeigtimz @echo SEP: Timing COMPLEX16 Symmetric Eigenvalue Problem routines - xeigtimz < ZSEPTIM.in > $@ 2>&1 + ./xeigtimz < ZSEPTIM.in > $@ 2>&1 zsvdtim.out: zsvdtim.in xeigtimz @echo SVD: Timing COMPLEX16 Singular Value Decomposition routines - xeigtimz < zsvdtim.in > $@ 2>&1 + ./xeigtimz < zsvdtim.in > $@ 2>&1 ZSVDTIM.out: ZSVDTIM.in xeigtimz @echo SVD: Timing COMPLEX16 Singular Value Decomposition routines - xeigtimz < ZSVDTIM.in > $@ 2>&1 + ./xeigtimz < ZSVDTIM.in > $@ 2>&1 # ============================================================================== xlintims: