94f7c34f5a
The content of this branch was automatically imported from Fedora ELN with the following as its source: https://src.fedoraproject.org/rpms/lapack#2410ec56df8810835d4c00d6692453a2854694f1
24101 lines
980 KiB
Diff
24101 lines
980 KiB
Diff
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:
|