saboi
/
molscat_14
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
molscat_14/lapack.f

12443 lines
376 KiB
Fortran
Raw Permalink Blame History

C ------------- BELOW IS DSYEVX --------------------
CAT > DSYEVX.F <<'CUT HERE............'
SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK,
$ IFAIL, INFO )
*
* -- LAPACK DRIVER ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* PURPOSE
* =======
*
* DSYEVX COMPUTES SELECTED EIGENVALUES AND, OPTIONALLY, EIGENVECTORS
* OF A REAL SYMMETRIC MATRIX A. EIGENVALUES AND EIGENVECTORS CAN BE
* SELECTED BY SPECIFYING EITHER A RANGE OF VALUES OR A RANGE OF INDICES
* FOR THE DESIRED EIGENVALUES.
*
* ARGUMENTS
* =========
*
* JOBZ (INPUT) CHARACTER*1
* = 'N': COMPUTE EIGENVALUES ONLY;
* = 'V': COMPUTE EIGENVALUES AND EIGENVECTORS.
*
* RANGE (INPUT) CHARACTER*1
* = 'A': ALL EIGENVALUES WILL BE FOUND.
* = 'V': ALL EIGENVALUES IN THE HALF-OPEN INTERVAL (VL,VU]
* WILL BE FOUND.
* = 'I': THE IL-TH THROUGH IU-TH EIGENVALUES WILL BE FOUND.
*
* UPLO (INPUT) CHARACTER*1
* = 'U': UPPER TRIANGLE OF A IS STORED;
* = 'L': LOWER TRIANGLE OF A IS STORED.
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX A. N >= 0.
*
* A (INPUT/WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LDA, N)
* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE
* LEADING N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE
* UPPER TRIANGULAR PART OF THE MATRIX A. IF UPLO = 'L',
* THE LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS
* THE LOWER TRIANGULAR PART OF THE MATRIX A.
* ON EXIT, THE LOWER TRIANGLE (IF UPLO='L') OR THE UPPER
* TRIANGLE (IF UPLO='U') OF A, INCLUDING THE DIAGONAL, IS
* DESTROYED.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N).
*
* VL (INPUT) DOUBLE PRECISION
* IF RANGE='V', THE LOWER BOUND OF THE INTERVAL TO BE SEARCHED
* FOR EIGENVALUES. NOT REFERENCED IF RANGE = 'A' OR 'I'.
*
* VU (INPUT) DOUBLE PRECISION
* IF RANGE='V', THE UPPER BOUND OF THE INTERVAL TO BE SEARCHED
* FOR EIGENVALUES. NOT REFERENCED IF RANGE = 'A' OR 'I'.
*
* IL (INPUT) INTEGER
* IF RANGE='I', THE INDEX (FROM SMALLEST TO LARGEST) OF THE
* SMALLEST EIGENVALUE TO BE RETURNED. IL >= 1.
* NOT REFERENCED IF RANGE = 'A' OR 'V'.
*
* IU (INPUT) INTEGER
* IF RANGE='I', THE INDEX (FROM SMALLEST TO LARGEST) OF THE
* LARGEST EIGENVALUE TO BE RETURNED. MIN(IL,N) <= IU <= N.
* NOT REFERENCED IF RANGE = 'A' OR 'V'.
*
* ABSTOL (INPUT) DOUBLE PRECISION
* THE ABSOLUTE ERROR TOLERANCE FOR THE EIGENVALUES.
* AN APPROXIMATE EIGENVALUE IS ACCEPTED AS CONVERGED
* WHEN IT IS DETERMINED TO LIE IN AN INTERVAL [A,B]
* OF WIDTH LESS THAN OR EQUAL TO
*
* ABSTOL + EPS * MAX( |A|,|B| ) ,
*
* WHERE EPS IS THE MACHINE PRECISION. IF ABSTOL IS LESS THAN
* OR EQUAL TO ZERO, THEN EPS*|T| WILL BE USED IN ITS PLACE,
* WHERE |T| IS THE 1-NORM OF THE TRIDIAGONAL MATRIX OBTAINED
* BY REDUCING A TO TRIDIAGONAL FORM.
*
* SEE "COMPUTING SMALL SINGULAR VALUES OF BIDIAGONAL MATRICES
* WITH GUARANTEED HIGH RELATIVE ACCURACY," BY DEMMEL AND
* KAHAN, LAPACK WORKING NOTE #3.
*
* M (OUTPUT) INTEGER
* THE TOTAL NUMBER OF EIGENVALUES FOUND. 0 <= M <= N.
* IF RANGE = 'A', M = N, AND IF RANGE = 'I', M = IU-IL+1.
*
* W (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* ON NORMAL EXIT, THE FIRST M ENTRIES CONTAIN THE SELECTED
* EIGENVALUES IN ASCENDING ORDER.
*
* Z (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDZ, MAX(1,M))
* IF JOBZ = 'V', THEN IF INFO = 0, THE FIRST M COLUMNS OF Z
* CONTAIN THE ORTHONORMAL EIGENVECTORS OF THE MATRIX
* CORRESPONDING TO THE SELECTED EIGENVALUES. IF AN EIGENVECTOR
* FAILS TO CONVERGE, THEN THAT COLUMN OF Z CONTAINS THE LATEST
* APPROXIMATION TO THE EIGENVECTOR, AND THE INDEX OF THE
* EIGENVECTOR IS RETURNED IN IFAIL.
* IF JOBZ = 'N', THEN Z IS NOT REFERENCED.
* NOTE: THE USER MUST ENSURE THAT AT LEAST MAX(1,M) COLUMNS ARE
* SUPPLIED IN THE ARRAY Z; IF RANGE = 'V', THE EXACT VALUE OF M
* IS NOT KNOWN IN ADVANCE AND AN UPPER BOUND MUST BE USED.
*
* LDZ (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY Z. LDZ >= 1, AND IF
* JOBZ = 'V', LDZ >= MAX(1,N).
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK)
* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK.
*
* LWORK (INPUT) INTEGER
* THE LENGTH OF THE ARRAY WORK. LWORK >= MAX(1,8*N).
* FOR OPTIMAL EFFICIENCY, LWORK >= (NB+3)*N,
* WHERE NB IS THE BLOCKSIZE FOR DSYTRD RETURNED BY ILAENV.
*
* IWORK (WORKSPACE) INTEGER ARRAY, DIMENSION (5*N)
*
* IFAIL (OUTPUT) INTEGER ARRAY, DIMENSION (N)
* IF JOBZ = 'V', THEN IF INFO = 0, THE FIRST M ELEMENTS OF
* IFAIL ARE ZERO. IF INFO > 0, THEN IFAIL CONTAINS THE
* INDICES OF THE EIGENVECTORS THAT FAILED TO CONVERGE.
* IF JOBZ = 'N', THEN IFAIL IS NOT REFERENCED.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
* > 0: IF INFO = I, THEN I EIGENVECTORS FAILED TO CONVERGE.
* THEIR INDICES ARE STORED IN ARRAY IFAIL.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. LOCAL SCALARS ..
LOGICAL ALLEIG, INDEIG, LOWER, VALEIG, WANTZ
CHARACTER ORDER
INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
$ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE,
$ ITMP1, J, JJ, LLWORK, LLWRKN, LOPT, NSPLIT
DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL LSAME, DLAMCH, DLANSY
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ,
$ DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS.
*
LOWER = LSAME( UPLO, 'L' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN
INFO = -8
ELSE IF( INDEIG .AND. IL.LT.1 ) THEN
INFO = -9
ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
INFO = -10
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -15
ELSE IF( LWORK.LT.MAX( 1, 8*N ) ) THEN
INFO = -17
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYEVX', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
M = 0
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( N.EQ.1 ) THEN
WORK( 1 ) = 7
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = A( 1, 1 )
ELSE
IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
M = 1
W( 1 ) = A( 1, 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* GET MACHINE CONSTANTS.
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
EPS = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* SCALE MATRIX TO ALLOWABLE RANGE, IF NECESSARY.
*
ISCALE = 0
ABSTLL = ABSTOL
IF( VALEIG ) THEN
VLL = VL
VUU = VU
END IF
ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
DO 10 J = 1, N
CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 )
10 CONTINUE
ELSE
DO 20 J = 1, N
CALL DSCAL( J, SIGMA, A( 1, J ), 1 )
20 CONTINUE
END IF
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* CALL DSYTRD TO REDUCE SYMMETRIC MATRIX TO TRIDIAGONAL FORM.
*
INDTAU = 1
INDE = INDTAU + N
INDD = INDE + N
INDWRK = INDD + N
LLWORK = LWORK - INDWRK + 1
CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
$ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO )
LOPT = 3*N + WORK( INDWRK )
*
* IF ALL EIGENVALUES ARE DESIRED AND ABSTOL IS LESS THAN OR EQUAL TO
* ZERO, THEN CALL DSTERF OR DORGTR AND SSTEQR. IF THIS FAILS FOR
* SOME EIGENVALUE, THEN TRY DSTEBZ.
*
IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND.
$ ( ABSTOL.LE.ZERO ) ) THEN
CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
INDEE = INDWRK + 2*N
IF( .NOT.WANTZ ) THEN
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ )
CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
$ WORK( INDWRK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 30 I = 1, N
IFAIL( I ) = 0
30 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 40
END IF
INFO = 0
END IF
*
* OTHERWISE, CALL DSTEBZ AND, IF EIGENVECTORS ARE DESIRED, SSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWO = INDISP + N
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
*
* APPLY ORTHOGONAL MATRIX USED IN REDUCTION TO TRIDIAGONAL
* FORM TO EIGENVECTORS RETURNED BY DSTEIN.
*
INDWKN = INDE
LLWRKN = LWORK - INDWKN + 1
CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
$ LDZ, WORK( INDWKN ), LLWRKN, IINFO )
END IF
*
* IF MATRIX WAS SCALED, THEN RESCALE EIGENVALUES APPROPRIATELY.
*
40 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* IF EIGENVALUES ARE NOT IN ORDER, THEN SORT THEM, ALONG WITH
* EIGENVECTORS.
*
IF( WANTZ ) THEN
DO 60 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 50 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
50 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
60 CONTINUE
END IF
*
* SET WORK(1) TO OPTIMAL WORKSPACE SIZE.
*
WORK( 1 ) = MAX( 7*N, LOPT )
*
RETURN
*
* END OF DSYEVX
*
END
CUT HERE............
CAT > DORMTR.F <<'CUT HERE............'
SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
CHARACTER SIDE, TRANS, UPLO
INTEGER INFO, LDA, LDC, LWORK, M, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* PURPOSE
* =======
*
* DORMTR OVERWRITES THE GENERAL REAL M-BY-N MATRIX C WITH
*
* SIDE = 'L' SIDE = 'R'
* TRANS = 'N': Q * C C * Q
* TRANS = 'T': Q**T * C C * Q**T
*
* WHERE Q IS A REAL ORTHOGONAL MATRIX OF ORDER NQ, WITH NQ = M IF
* SIDE = 'L' AND NQ = N IF SIDE = 'R'. Q IS DEFINED AS THE PRODUCT OF
* NQ-1 ELEMENTARY REFLECTORS, AS RETURNED BY DSYTRD:
*
* IF UPLO = 'U', Q = H(NQ-1) . . . H(2) H(1);
*
* IF UPLO = 'L', Q = H(1) H(2) . . . H(NQ-1).
*
* ARGUMENTS
* =========
*
* SIDE (INPUT) CHARACTER*1
* = 'L': APPLY Q OR Q**T FROM THE LEFT;
* = 'R': APPLY Q OR Q**T FROM THE RIGHT.
*
* UPLO (INPUT) CHARACTER*1
* = 'U': UPPER TRIANGLE OF A CONTAINS ELEMENTARY REFLECTORS
* FROM DSYTRD;
* = 'L': LOWER TRIANGLE OF A CONTAINS ELEMENTARY REFLECTORS
* FROM DSYTRD.
*
* TRANS (INPUT) CHARACTER*1
* = 'N': NO TRANSPOSE, APPLY Q;
* = 'T': TRANSPOSE, APPLY Q**T.
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX C. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX C. N >= 0.
*
* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION
* (LDA,M) IF SIDE = 'L'
* (LDA,N) IF SIDE = 'R'
* THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS, AS
* RETURNED BY DSYTRD.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A.
* LDA >= MAX(1,M) IF SIDE = 'L'; LDA >= MAX(1,N) IF SIDE = 'R'.
*
* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION
* (M-1) IF SIDE = 'L'
* (N-1) IF SIDE = 'R'
* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY
* REFLECTOR H(I), AS RETURNED BY DSYTRD.
*
* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N)
* ON ENTRY, THE M-BY-N MATRIX C.
* ON EXIT, C IS OVERWRITTEN BY Q*C OR Q**T*C OR C*Q**T OR C*Q.
*
* LDC (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M).
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK)
* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK.
*
* LWORK (INPUT) INTEGER
* THE DIMENSION OF THE ARRAY WORK.
* IF SIDE = 'L', LWORK >= MAX(1,N);
* IF SIDE = 'R', LWORK >= MAX(1,M).
* FOR OPTIMUM PERFORMANCE LWORK >= N*NB IF SIDE = 'L', AND
* LWORK >= M*NB IF SIDE = 'R', WHERE NB IS THE OPTIMAL
* BLOCKSIZE.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
*
* =====================================================================
*
* .. LOCAL SCALARS ..
LOGICAL LEFT, UPPER
INTEGER I1, I2, IINFO, MI, NI, NQ, NW
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DORMQL, DORMQR, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT ARGUMENTS
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
UPPER = LSAME( UPLO, 'U' )
*
* NQ IS THE ORDER OF Q AND NW IS THE MINIMUM DIMENSION OF WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
$ THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMTR', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( LEFT ) THEN
MI = M - 1
NI = N
ELSE
MI = M
NI = N - 1
END IF
*
IF( UPPER ) THEN
*
* Q WAS DETERMINED BY A CALL TO DSYTRD WITH UPLO = 'U'
*
CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
$ LDC, WORK, LWORK, IINFO )
ELSE
*
* Q WAS DETERMINED BY A CALL TO DSYTRD WITH UPLO = 'L'
*
IF( LEFT ) THEN
I1 = 2
I2 = 1
ELSE
I1 = 1
I2 = 2
END IF
CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
$ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
RETURN
*
* END OF DORMTR
*
END
CUT HERE............
CAT > DORMQR.F <<'CUT HERE............'
SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* PURPOSE
* =======
*
* DORMQR OVERWRITES THE GENERAL REAL M-BY-N MATRIX C WITH
*
* SIDE = 'L' SIDE = 'R'
* TRANS = 'N': Q * C C * Q
* TRANS = 'T': Q**T * C C * Q**T
*
* WHERE Q IS A REAL ORTHOGONAL MATRIX DEFINED AS THE PRODUCT OF K
* ELEMENTARY REFLECTORS
*
* Q = H(1) H(2) . . . H(K)
*
* AS RETURNED BY DGEQRF. Q IS OF ORDER M IF SIDE = 'L' AND OF ORDER N
* IF SIDE = 'R'.
*
* ARGUMENTS
* =========
*
* SIDE (INPUT) CHARACTER*1
* = 'L': APPLY Q OR Q**T FROM THE LEFT;
* = 'R': APPLY Q OR Q**T FROM THE RIGHT.
*
* TRANS (INPUT) CHARACTER*1
* = 'N': NO TRANSPOSE, APPLY Q;
* = 'T': TRANSPOSE, APPLY Q**T.
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX C. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX C. N >= 0.
*
* K (INPUT) INTEGER
* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES
* THE MATRIX Q.
* IF SIDE = 'L', M >= K >= 0;
* IF SIDE = 'R', N >= K >= 0.
*
* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,K)
* THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH DEFINES THE
* ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS RETURNED BY
* DGEQRF IN THE FIRST K COLUMNS OF ITS ARRAY ARGUMENT A.
* A IS MODIFIED BY THE ROUTINE BUT RESTORED ON EXIT.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A.
* IF SIDE = 'L', LDA >= MAX(1,M);
* IF SIDE = 'R', LDA >= MAX(1,N).
*
* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K)
* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY
* REFLECTOR H(I), AS RETURNED BY DGEQRF.
*
* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N)
* ON ENTRY, THE M-BY-N MATRIX C.
* ON EXIT, C IS OVERWRITTEN BY Q*C OR Q**T*C OR C*Q**T OR C*Q.
*
* LDC (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M).
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK)
* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK.
*
* LWORK (INPUT) INTEGER
* THE DIMENSION OF THE ARRAY WORK.
* IF SIDE = 'L', LWORK >= MAX(1,N);
* IF SIDE = 'R', LWORK >= MAX(1,M).
* FOR OPTIMUM PERFORMANCE LWORK >= N*NB IF SIDE = 'L', AND
* LWORK >= M*NB IF SIDE = 'R', WHERE NB IS THE OPTIMAL
* BLOCKSIZE.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
*
* =====================================================================
*
* .. PARAMETERS ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
* ..
* .. LOCAL SCALARS ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
$ MI, NB, NBMIN, NI, NQ, NW
* ..
* .. LOCAL ARRAYS ..
DOUBLE PRECISION T( LDT, NBMAX )
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX, MIN
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT ARGUMENTS
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ IS THE ORDER OF Q AND NW IS THE MINIMUM DIMENSION OF WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMQR', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* DETERMINE THE BLOCK SIZE. NB MAY BE AT MOST NBMAX, WHERE NBMAX
* IS USED TO DEFINE THE LOCAL ARRAY T.
*
NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K,
$ -1 ) )
NBMIN = 2
LDWORK = NW
IF( NB.GT.1 .AND. NB.LT.K ) THEN
IWS = NW*NB
IF( LWORK.LT.IWS ) THEN
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K,
$ -1 ) )
END IF
ELSE
IWS = NW
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* USE UNBLOCKED CODE
*
CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
$ IINFO )
ELSE
*
* USE BLOCKED CODE
*
IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = NB
ELSE
I1 = ( ( K-1 ) / NB )*NB + 1
I2 = 1
I3 = -NB
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IB = MIN( NB, K-I+1 )
*
* FORM THE TRIANGULAR FACTOR OF THE BLOCK REFLECTOR
* H = H(I) H(I+1) . . . H(I+IB-1)
*
CALL DLARFT( 'FORWARD', 'COLUMNWISE', NQ-I+1, IB, A( I, I ),
$ LDA, TAU( I ), T, LDT )
IF( LEFT ) THEN
*
* H OR H' IS APPLIED TO C(I:M,1:N)
*
MI = M - I + 1
IC = I
ELSE
*
* H OR H' IS APPLIED TO C(1:M,I:N)
*
NI = N - I + 1
JC = I
END IF
*
* APPLY H OR H'
*
CALL DLARFB( SIDE, TRANS, 'FORWARD', 'COLUMNWISE', MI, NI,
$ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC,
$ WORK, LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = IWS
RETURN
*
* END OF DORMQR
*
END
CUT HERE............
CAT > DORM2R.F <<'CUT HERE............'
SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* FEBRUARY 29, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* PURPOSE
* =======
*
* DORM2R OVERWRITES THE GENERAL REAL M BY N MATRIX C WITH
*
* Q * C IF SIDE = 'L' AND TRANS = 'N', OR
*
* Q'* C IF SIDE = 'L' AND TRANS = 'T', OR
*
* C * Q IF SIDE = 'R' AND TRANS = 'N', OR
*
* C * Q' IF SIDE = 'R' AND TRANS = 'T',
*
* WHERE Q IS A REAL ORTHOGONAL MATRIX DEFINED AS THE PRODUCT OF K
* ELEMENTARY REFLECTORS
*
* Q = H(1) H(2) . . . H(K)
*
* AS RETURNED BY DGEQRF. Q IS OF ORDER M IF SIDE = 'L' AND OF ORDER N
* IF SIDE = 'R'.
*
* ARGUMENTS
* =========
*
* SIDE (INPUT) CHARACTER*1
* = 'L': APPLY Q OR Q' FROM THE LEFT
* = 'R': APPLY Q OR Q' FROM THE RIGHT
*
* TRANS (INPUT) CHARACTER*1
* = 'N': APPLY Q (NO TRANSPOSE)
* = 'T': APPLY Q' (TRANSPOSE)
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX C. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX C. N >= 0.
*
* K (INPUT) INTEGER
* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES
* THE MATRIX Q.
* IF SIDE = 'L', M >= K >= 0;
* IF SIDE = 'R', N >= K >= 0.
*
* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,K)
* THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH DEFINES THE
* ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS RETURNED BY
* DGEQRF IN THE FIRST K COLUMNS OF ITS ARRAY ARGUMENT A.
* A IS MODIFIED BY THE ROUTINE BUT RESTORED ON EXIT.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A.
* IF SIDE = 'L', LDA >= MAX(1,M);
* IF SIDE = 'R', LDA >= MAX(1,N).
*
* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K)
* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY
* REFLECTOR H(I), AS RETURNED BY DGEQRF.
*
* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N)
* ON ENTRY, THE M BY N MATRIX C.
* ON EXIT, C IS OVERWRITTEN BY Q*C OR Q'*C OR C*Q' OR C*Q.
*
* LDC (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M).
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION
* (N) IF SIDE = 'L',
* (M) IF SIDE = 'R'
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. LOCAL SCALARS ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
DOUBLE PRECISION AII
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLARF, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT ARGUMENTS
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ IS THE ORDER OF Q
*
IF( LEFT ) THEN
NQ = M
ELSE
NQ = N
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORM2R', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) )
$ THEN
I1 = 1
I2 = K
I3 = 1
ELSE
I1 = K
I2 = 1
I3 = -1
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(I) IS APPLIED TO C(I:M,1:N)
*
MI = M - I + 1
IC = I
ELSE
*
* H(I) IS APPLIED TO C(1:M,I:N)
*
NI = N - I + 1
JC = I
END IF
*
* APPLY H(I)
*
AII = A( I, I )
A( I, I ) = ONE
CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ),
$ LDC, WORK )
A( I, I ) = AII
10 CONTINUE
RETURN
*
* END OF DORM2R
*
END
CUT HERE............
CAT > DORMQL.F <<'CUT HERE............'
SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ),
$ WORK( LWORK )
* ..
*
* PURPOSE
* =======
*
* DORMQL OVERWRITES THE GENERAL REAL M-BY-N MATRIX C WITH
*
* SIDE = 'L' SIDE = 'R'
* TRANS = 'N': Q * C C * Q
* TRANS = 'T': Q**T * C C * Q**T
*
* WHERE Q IS A REAL ORTHOGONAL MATRIX DEFINED AS THE PRODUCT OF K
* ELEMENTARY REFLECTORS
*
* Q = H(K) . . . H(2) H(1)
*
* AS RETURNED BY DGEQLF. Q IS OF ORDER M IF SIDE = 'L' AND OF ORDER N
* IF SIDE = 'R'.
*
* ARGUMENTS
* =========
*
* SIDE (INPUT) CHARACTER*1
* = 'L': APPLY Q OR Q**T FROM THE LEFT;
* = 'R': APPLY Q OR Q**T FROM THE RIGHT.
*
* TRANS (INPUT) CHARACTER*1
* = 'N': NO TRANSPOSE, APPLY Q;
* = 'T': TRANSPOSE, APPLY Q**T.
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX C. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX C. N >= 0.
*
* K (INPUT) INTEGER
* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES
* THE MATRIX Q.
* IF SIDE = 'L', M >= K >= 0;
* IF SIDE = 'R', N >= K >= 0.
*
* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,K)
* THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH DEFINES THE
* ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS RETURNED BY
* DGEQLF IN THE LAST K COLUMNS OF ITS ARRAY ARGUMENT A.
* A IS MODIFIED BY THE ROUTINE BUT RESTORED ON EXIT.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A.
* IF SIDE = 'L', LDA >= MAX(1,M);
* IF SIDE = 'R', LDA >= MAX(1,N).
*
* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K)
* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY
* REFLECTOR H(I), AS RETURNED BY DGEQLF.
*
* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N)
* ON ENTRY, THE M-BY-N MATRIX C.
* ON EXIT, C IS OVERWRITTEN BY Q*C OR Q**T*C OR C*Q**T OR C*Q.
*
* LDC (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M).
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK)
* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK.
*
* LWORK (INPUT) INTEGER
* THE DIMENSION OF THE ARRAY WORK.
* IF SIDE = 'L', LWORK >= MAX(1,N);
* IF SIDE = 'R', LWORK >= MAX(1,M).
* FOR OPTIMUM PERFORMANCE LWORK >= N*NB IF SIDE = 'L', AND
* LWORK >= M*NB IF SIDE = 'R', WHERE NB IS THE OPTIMAL
* BLOCKSIZE.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
*
* =====================================================================
*
* .. PARAMETERS ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
* ..
* .. LOCAL SCALARS ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, MI, NB,
$ NBMIN, NI, NQ, NW
* ..
* .. LOCAL ARRAYS ..
DOUBLE PRECISION T( LDT, NBMAX )
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLARFB, DLARFT, DORM2L, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX, MIN
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT ARGUMENTS
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ IS THE ORDER OF Q AND NW IS THE MINIMUM DIMENSION OF WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMQL', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* DETERMINE THE BLOCK SIZE. NB MAY BE AT MOST NBMAX, WHERE NBMAX
* IS USED TO DEFINE THE LOCAL ARRAY T.
*
NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, K,
$ -1 ) )
NBMIN = 2
LDWORK = NW
IF( NB.GT.1 .AND. NB.LT.K ) THEN
IWS = NW*NB
IF( LWORK.LT.IWS ) THEN
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K,
$ -1 ) )
END IF
ELSE
IWS = NW
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* USE UNBLOCKED CODE
*
CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
$ IINFO )
ELSE
*
* USE BLOCKED CODE
*
IF( ( LEFT .AND. NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = NB
ELSE
I1 = ( ( K-1 ) / NB )*NB + 1
I2 = 1
I3 = -NB
END IF
*
IF( LEFT ) THEN
NI = N
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IB = MIN( NB, K-I+1 )
*
* FORM THE TRIANGULAR FACTOR OF THE BLOCK REFLECTOR
* H = H(I+IB-1) . . . H(I+1) H(I)
*
CALL DLARFT( 'BACKWARD', 'COLUMNWISE', NQ-K+I+IB-1, IB,
$ A( 1, I ), LDA, TAU( I ), T, LDT )
IF( LEFT ) THEN
*
* H OR H' IS APPLIED TO C(1:M-K+I+IB-1,1:N)
*
MI = M - K + I + IB - 1
ELSE
*
* H OR H' IS APPLIED TO C(1:M,1:N-K+I+IB-1)
*
NI = N - K + I + IB - 1
END IF
*
* APPLY H OR H'
*
CALL DLARFB( SIDE, TRANS, 'BACKWARD', 'COLUMNWISE', MI, NI,
$ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK,
$ LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = IWS
RETURN
*
* END OF DORMQL
*
END
CUT HERE............
CAT > DORM2L.F <<'CUT HERE............'
SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* FEBRUARY 29, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* PURPOSE
* =======
*
* DORM2L OVERWRITES THE GENERAL REAL M BY N MATRIX C WITH
*
* Q * C IF SIDE = 'L' AND TRANS = 'N', OR
*
* Q'* C IF SIDE = 'L' AND TRANS = 'T', OR
*
* C * Q IF SIDE = 'R' AND TRANS = 'N', OR
*
* C * Q' IF SIDE = 'R' AND TRANS = 'T',
*
* WHERE Q IS A REAL ORTHOGONAL MATRIX DEFINED AS THE PRODUCT OF K
* ELEMENTARY REFLECTORS
*
* Q = H(K) . . . H(2) H(1)
*
* AS RETURNED BY DGEQLF. Q IS OF ORDER M IF SIDE = 'L' AND OF ORDER N
* IF SIDE = 'R'.
*
* ARGUMENTS
* =========
*
* SIDE (INPUT) CHARACTER*1
* = 'L': APPLY Q OR Q' FROM THE LEFT
* = 'R': APPLY Q OR Q' FROM THE RIGHT
*
* TRANS (INPUT) CHARACTER*1
* = 'N': APPLY Q (NO TRANSPOSE)
* = 'T': APPLY Q' (TRANSPOSE)
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX C. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX C. N >= 0.
*
* K (INPUT) INTEGER
* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES
* THE MATRIX Q.
* IF SIDE = 'L', M >= K >= 0;
* IF SIDE = 'R', N >= K >= 0.
*
* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,K)
* THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH DEFINES THE
* ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS RETURNED BY
* DGEQLF IN THE LAST K COLUMNS OF ITS ARRAY ARGUMENT A.
* A IS MODIFIED BY THE ROUTINE BUT RESTORED ON EXIT.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A.
* IF SIDE = 'L', LDA >= MAX(1,M);
* IF SIDE = 'R', LDA >= MAX(1,N).
*
* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K)
* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY
* REFLECTOR H(I), AS RETURNED BY DGEQLF.
*
* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N)
* ON ENTRY, THE M BY N MATRIX C.
* ON EXIT, C IS OVERWRITTEN BY Q*C OR Q'*C OR C*Q' OR C*Q.
*
* LDC (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M).
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION
* (N) IF SIDE = 'L',
* (M) IF SIDE = 'R'
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. LOCAL SCALARS ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
DOUBLE PRECISION AII
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLARF, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT ARGUMENTS
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ IS THE ORDER OF Q
*
IF( LEFT ) THEN
NQ = M
ELSE
NQ = N
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORM2L', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) )
$ THEN
I1 = 1
I2 = K
I3 = 1
ELSE
I1 = K
I2 = 1
I3 = -1
END IF
*
IF( LEFT ) THEN
NI = N
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(I) IS APPLIED TO C(1:M-K+I,1:N)
*
MI = M - K + I
ELSE
*
* H(I) IS APPLIED TO C(1:M,1:N-K+I)
*
NI = N - K + I
END IF
*
* APPLY H(I)
*
AII = A( NQ-K+I, I )
A( NQ-K+I, I ) = ONE
CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC,
$ WORK )
A( NQ-K+I, I ) = AII
10 CONTINUE
RETURN
*
* END OF DORM2L
*
END
CUT HERE............
CAT > DSTEIN.F <<'CUT HERE............'
SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
$ IWORK, IFAIL, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
INTEGER INFO, LDZ, M, N
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
$ IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* PURPOSE
* =======
*
* DSTEIN COMPUTES THE EIGENVECTORS OF A REAL SYMMETRIC TRIDIAGONAL
* MATRIX T CORRESPONDING TO SPECIFIED EIGENVALUES, USING INVERSE
* ITERATION.
*
* THE MAXIMUM NUMBER OF ITERATIONS ALLOWED FOR EACH EIGENVECTOR IS
* SPECIFIED BY AN INTERNAL PARAMETER MAXITS (CURRENTLY SET TO 5).
*
* ARGUMENTS
* =========
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX. N >= 0.
*
* D (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* THE N DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T.
*
* E (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* THE (N-1) SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX
* T, IN ELEMENTS 1 TO N-1. E(N) NEED NOT BE SET.
*
* M (INPUT) INTEGER
* THE NUMBER OF EIGENVECTORS TO BE FOUND. 0 <= M <= N.
*
* W (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* THE FIRST M ELEMENTS OF W CONTAIN THE EIGENVALUES FOR
* WHICH EIGENVECTORS ARE TO BE COMPUTED. THE EIGENVALUES
* SHOULD BE GROUPED BY SPLIT-OFF BLOCK AND ORDERED FROM
* SMALLEST TO LARGEST WITHIN THE BLOCK. ( THE OUTPUT ARRAY
* W FROM DSTEBZ WITH ORDER = 'B' IS EXPECTED HERE. )
*
* IBLOCK (INPUT) INTEGER ARRAY, DIMENSION (N)
* THE SUBMATRIX INDICES ASSOCIATED WITH THE CORRESPONDING
* EIGENVALUES IN W; IBLOCK(I)=1 IF EIGENVALUE W(I) BELONGS TO
* THE FIRST SUBMATRIX FROM THE TOP, =2 IF W(I) BELONGS TO
* THE SECOND SUBMATRIX, ETC. ( THE OUTPUT ARRAY IBLOCK
* FROM DSTEBZ IS EXPECTED HERE. )
*
* ISPLIT (INPUT) INTEGER ARRAY, DIMENSION (N)
* THE SPLITTING POINTS, AT WHICH T BREAKS UP INTO SUBMATRICES.
* THE FIRST SUBMATRIX CONSISTS OF ROWS/COLUMNS 1 TO
* ISPLIT( 1 ), THE SECOND OF ROWS/COLUMNS ISPLIT( 1 )+1
* THROUGH ISPLIT( 2 ), ETC.
* ( THE OUTPUT ARRAY ISPLIT FROM DSTEBZ IS EXPECTED HERE. )
*
* Z (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDZ, M)
* THE COMPUTED EIGENVECTORS. THE EIGENVECTOR ASSOCIATED
* WITH THE EIGENVALUE W(I) IS STORED IN THE I-TH COLUMN OF
* Z. ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ITS CURRENT
* ITERATE AFTER MAXITS ITERATIONS.
*
* LDZ (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY Z. LDZ >= MAX(1,N).
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (5*N)
*
* IWORK (WORKSPACE) INTEGER ARRAY, DIMENSION (N)
*
* IFAIL (OUTPUT) INTEGER ARRAY, DIMENSION (M)
* ON NORMAL EXIT, ALL ELEMENTS OF IFAIL ARE ZERO.
* IF ONE OR MORE EIGENVECTORS FAIL TO CONVERGE AFTER
* MAXITS ITERATIONS, THEN THEIR INDICES ARE STORED IN
* ARRAY IFAIL.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT.
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
* > 0: IF INFO = I, THEN I EIGENVECTORS FAILED TO CONVERGE
* IN MAXITS ITERATIONS. THEIR INDICES ARE STORED IN
* ARRAY IFAIL.
*
* INTERNAL PARAMETERS
* ===================
*
* MAXITS INTEGER, DEFAULT = 5
* THE MAXIMUM NUMBER OF ITERATIONS PERFORMED.
*
* EXTRA INTEGER, DEFAULT = 2
* THE NUMBER OF ITERATIONS PERFORMED AFTER NORM GROWTH
* CRITERION IS SATISFIED, SHOULD BE AT LEAST 1.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 1.0D1,
$ ODM3 = 1.0D-3, ODM1 = 1.0D-1 )
INTEGER MAXITS, EXTRA
PARAMETER ( MAXITS = 5, EXTRA = 2 )
* ..
* .. LOCAL SCALARS ..
INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
$ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
$ JBLK, JMAX, NBLK, NRMCHK
DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
$ SCL, SEP, TOL, XJ, XJM, ZTR
* ..
* .. LOCAL ARRAYS ..
INTEGER ISEED( 4 )
* ..
* .. EXTERNAL FUNCTIONS ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DDOT, DLAMCH, DNRM2
EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DNRM2
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL,
$ XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS.
*
INFO = 0
DO 10 I = 1, M
IFAIL( I ) = 0
10 CONTINUE
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
INFO = -4
ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
DO 20 J = 2, M
IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
INFO = -6
GO TO 30
END IF
IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
$ THEN
INFO = -5
GO TO 30
END IF
20 CONTINUE
30 CONTINUE
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEIN', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( N.EQ.0 .OR. M.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
Z( 1, 1 ) = ONE
RETURN
END IF
*
* GET MACHINE CONSTANTS.
*
EPS = DLAMCH( 'PRECISION' )
*
* INITIALIZE SEED FOR RANDOM NUMBER GENERATOR DLARNV.
*
DO 40 I = 1, 4
ISEED( I ) = 1
40 CONTINUE
*
* INITIALIZE POINTERS.
*
INDRV1 = 0
INDRV2 = INDRV1 + N
INDRV3 = INDRV2 + N
INDRV4 = INDRV3 + N
INDRV5 = INDRV4 + N
*
* COMPUTE EIGENVECTORS OF MATRIX BLOCKS.
*
GPIND = 1
J1 = 1
DO 160 NBLK = 1, IBLOCK( M )
*
* FIND STARTING AND ENDING INDICES OF BLOCK NBLK.
*
IF( NBLK.EQ.1 ) THEN
B1 = 1
ELSE
B1 = ISPLIT( NBLK-1 ) + 1
END IF
BN = ISPLIT( NBLK )
BLKSIZ = BN - B1 + 1
IF( BLKSIZ.EQ.1 )
$ GO TO 60
*
* COMPUTE REORTHOGONALIZATION CRITERION AND STOPPING CRITERION.
*
ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
DO 50 I = B1 + 1, BN - 1
ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
$ ABS( E( I ) ) )
50 CONTINUE
ORTOL = ODM3*ONENRM
*
DTPCRT = SQRT( ODM1 / BLKSIZ )
*
* LOOP THROUGH EIGENVALUES OF BLOCK NBLK.
*
60 CONTINUE
JBLK = 0
DO 150 J = J1, M
IF( IBLOCK( J ).NE.NBLK ) THEN
J1 = J
GO TO 160
END IF
JBLK = JBLK + 1
XJ = W( J )
*
* SKIP ALL THE WORK IF THE BLOCK SIZE IS ONE.
*
IF( BLKSIZ.EQ.1 ) THEN
WORK( INDRV1+1 ) = ONE
GO TO 120
END IF
*
* IF EIGENVALUES J AND J-1 ARE TOO CLOSE, ADD A RELATIVELY
* SMALL PERTURBATION.
*
IF( JBLK.GT.1 ) THEN
EPS1 = ABS( EPS*XJ )
PERTOL = TEN*EPS1
SEP = XJ - XJM
IF( SEP.LT.PERTOL )
$ XJ = XJM + PERTOL
END IF
*
ITS = 0
NRMCHK = 0
*
* GET RANDOM STARTING VECTOR.
*
CALL DLARNV( 3, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
*
* COPY THE MATRIX T SO IT WON'T BE DESTROYED IN FACTORIZATION.
*
CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
*
* COMPUTE LU FACTORS WITH PARTIAL PIVOTING ( PT = LU )
*
TOL = ZERO
CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
$ IINFO )
*
* UPDATE ITERATION COUNT.
*
70 CONTINUE
ITS = ITS + 1
IF( ITS.GT.MAXITS )
$ GO TO 100
*
* NORMALIZE AND SCALE THE RIGHTHAND SIDE VECTOR PB.
*
SCL = BLKSIZ*ONENRM*MAX( EPS,
$ ABS( WORK( INDRV4+BLKSIZ ) ) ) /
$ DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 )
CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
*
* SOLVE THE SYSTEM LU = PB.
*
CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
$ WORK( INDRV1+1 ), TOL, IINFO )
*
* REORTHOGONALIZE BY MODIFIED GRAM-SCHMIDT IF EIGENVALUES ARE
* CLOSE ENOUGH.
*
IF( JBLK.EQ.1 )
$ GO TO 90
IF( ABS( XJ-XJM ).GT.ORTOL )
$ GPIND = J
IF( GPIND.NE.J ) THEN
DO 80 I = GPIND, J - 1
ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ),
$ 1 )
CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1,
$ WORK( INDRV1+1 ), 1 )
80 CONTINUE
END IF
*
* CHECK THE INFINITY NORM OF THE ITERATE.
*
90 CONTINUE
JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
NRM = ABS( WORK( INDRV1+JMAX ) )
*
* CONTINUE FOR ADDITIONAL ITERATIONS AFTER NORM REACHES
* STOPPING CRITERION.
*
IF( NRM.LT.DTPCRT )
$ GO TO 70
NRMCHK = NRMCHK + 1
IF( NRMCHK.LT.EXTRA+1 )
$ GO TO 70
*
GO TO 110
*
* IF STOPPING CRITERION WAS NOT SATISFIED, UPDATE INFO AND
* STORE EIGENVECTOR NUMBER IN ARRAY IFAIL.
*
100 CONTINUE
INFO = INFO + 1
IFAIL( INFO ) = J
*
* ACCEPT ITERATE AS JTH EIGENVECTOR.
*
110 CONTINUE
SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
IF( WORK( INDRV1+JMAX ).LT.ZERO )
$ SCL = -SCL
CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
120 CONTINUE
DO 130 I = 1, N
Z( I, J ) = ZERO
130 CONTINUE
DO 140 I = 1, BLKSIZ
Z( B1+I-1, J ) = WORK( INDRV1+I )
140 CONTINUE
*
* SAVE THE SHIFT TO CHECK EIGENVALUE SPACING AT NEXT
* ITERATION.
*
XJM = XJ
*
150 CONTINUE
160 CONTINUE
*
RETURN
*
* END OF DSTEIN
*
END
CUT HERE............
CAT > DLAGTS.F <<'CUT HERE............'
SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
INTEGER INFO, JOB, N
DOUBLE PRECISION TOL
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IN( * )
DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * )
* ..
*
* PURPOSE
* =======
*
* DLAGTS MAY BE USED TO SOLVE ONE OF THE SYSTEMS OF EQUATIONS
*
* (T - LAMBDA*I)*X = Y OR (T - LAMBDA*I)'*X = Y,
*
* WHERE T IS AN N BY N TRIDIAGONAL MATRIX, FOR X, FOLLOWING THE
* FACTORIZATION OF (T - LAMBDA*I) AS
*
* (T - LAMBDA*I) = P*L*U ,
*
* BY ROUTINE DLAGTF. THE CHOICE OF EQUATION TO BE SOLVED IS
* CONTROLLED BY THE ARGUMENT JOB, AND IN EACH CASE THERE IS AN OPTION
* TO PERTURB ZERO OR VERY SMALL DIAGONAL ELEMENTS OF U, THIS OPTION
* BEING INTENDED FOR USE IN APPLICATIONS SUCH AS INVERSE ITERATION.
*
* ARGUMENTS
* =========
*
* JOB (INPUT) INTEGER
* SPECIFIES THE JOB TO BE PERFORMED BY DLAGTS AS FOLLOWS:
* = 1: THE EQUATIONS (T - LAMBDA*I)X = Y ARE TO BE SOLVED,
* BUT DIAGONAL ELEMENTS OF U ARE NOT TO BE PERTURBED.
* = -1: THE EQUATIONS (T - LAMBDA*I)X = Y ARE TO BE SOLVED
* AND, IF OVERFLOW WOULD OTHERWISE OCCUR, THE DIAGONAL
* ELEMENTS OF U ARE TO BE PERTURBED. SEE ARGUMENT TOL
* BELOW.
* = 2: THE EQUATIONS (T - LAMBDA*I)'X = Y ARE TO BE SOLVED,
* BUT DIAGONAL ELEMENTS OF U ARE NOT TO BE PERTURBED.
* = -2: THE EQUATIONS (T - LAMBDA*I)'X = Y ARE TO BE SOLVED
* AND, IF OVERFLOW WOULD OTHERWISE OCCUR, THE DIAGONAL
* ELEMENTS OF U ARE TO BE PERTURBED. SEE ARGUMENT TOL
* BELOW.
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX T.
*
* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* ON ENTRY, A MUST CONTAIN THE DIAGONAL ELEMENTS OF U AS
* RETURNED FROM DLAGTF.
*
* B (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* ON ENTRY, B MUST CONTAIN THE FIRST SUPER-DIAGONAL ELEMENTS OF
* U AS RETURNED FROM DLAGTF.
*
* C (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* ON ENTRY, C MUST CONTAIN THE SUB-DIAGONAL ELEMENTS OF L AS
* RETURNED FROM DLAGTF.
*
* D (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-2)
* ON ENTRY, D MUST CONTAIN THE SECOND SUPER-DIAGONAL ELEMENTS
* OF U AS RETURNED FROM DLAGTF.
*
* IN (INPUT) INTEGER ARRAY, DIMENSION (N)
* ON ENTRY, IN MUST CONTAIN DETAILS OF THE MATRIX P AS RETURNED
* FROM DLAGTF.
*
* Y (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* ON ENTRY, THE RIGHT HAND SIDE VECTOR Y.
*
* ON EXIT, Y IS OVERWRITTEN BY THE SOLUTION VECTOR X.
*
* TOL (INPUT/OUTPUT) DOUBLE PRECISION
* ON ENTRY WITH JOB .LT. 0, TOL SHOULD BE THE MINIMUM
* PERTURBATION TO BE MADE TO VERY SMALL DIAGONAL ELEMENTS OF U.
* TOL SHOULD NORMALLY BE CHOSEN AS ABOUT EPS*NORM(U), WHERE EPS
* IS THE RELATIVE MACHINE PRECISION, BUT IF TOL IS SUPPLIED AS
* NON-POSITIVE, THEN IT IS RESET TO EPS*MAX( ABS( U(I,J) ) ).
* IF JOB .GT. 0 THEN TOL IS NOT REFERENCED.
*
* ON EXIT, TOL IS CHANGED AS DESCRIBED ABOVE, ONLY IF TOL IS
* NON-POSITIVE ON ENTRY. OTHERWISE TOL IS UNCHANGED.
*
* INFO (OUTPUT)
* = 0 : SUCCESSFUL EXIT
* .LT. 0: IF INFO = -K, THE KTH ARGUMENT HAD AN ILLEGAL VALUE
* .GT. 0: OVERFLOW WOULD OCCUR WHEN COMPUTING THE INFO(TH)
* ELEMENT OF THE SOLUTION VECTOR X. THIS CAN ONLY OCCUR
* WHEN JOB IS SUPPLIED AS POSITIVE AND EITHER MEANS
* THAT A DIAGONAL ELEMENT OF U IS VERY SMALL, OR THAT
* THE ELEMENTS OF THE RIGHT-HAND SIDE VECTOR Y ARE VERY
* LARGE.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER K
DOUBLE PRECISION ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, MAX, SIGN
* ..
* .. EXTERNAL FUNCTIONS ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL XERBLA
* ..
* .. EXECUTABLE STATEMENTS ..
*
INFO = 0
IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAGTS', -INFO )
RETURN
END IF
*
IF( N.EQ.0 )
$ RETURN
*
EPS = DLAMCH( 'EPSILON' )
SFMIN = DLAMCH( 'SAFE MINIMUM' )
BIGNUM = ONE / SFMIN
*
IF( JOB.LT.0 ) THEN
IF( TOL.LE.ZERO ) THEN
TOL = ABS( A( 1 ) )
IF( N.GT.1 )
$ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) )
DO 10 K = 3, N
TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ),
$ ABS( D( K-2 ) ) )
10 CONTINUE
TOL = TOL*EPS
IF( TOL.EQ.ZERO )
$ TOL = EPS
END IF
END IF
*
IF( ABS( JOB ).EQ.1 ) THEN
DO 20 K = 2, N
IF( IN( K-1 ).EQ.0 ) THEN
Y( K ) = Y( K ) - C( K-1 )*Y( K-1 )
ELSE
TEMP = Y( K-1 )
Y( K-1 ) = Y( K )
Y( K ) = TEMP - C( K-1 )*Y( K )
END IF
20 CONTINUE
IF( JOB.EQ.1 ) THEN
DO 30 K = N, 1, -1
IF( K.LE.N-2 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
ELSE IF( K.EQ.N-1 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
INFO = K
RETURN
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
INFO = K
RETURN
END IF
END IF
Y( K ) = TEMP / AK
30 CONTINUE
ELSE
DO 50 K = N, 1, -1
IF( K.LE.N-2 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
ELSE IF( K.EQ.N-1 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
PERT = SIGN( TOL, AK )
40 CONTINUE
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 40
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 40
END IF
END IF
Y( K ) = TEMP / AK
50 CONTINUE
END IF
ELSE
*
* COME TO HERE IF JOB = 2 OR -2
*
IF( JOB.EQ.2 ) THEN
DO 60 K = 1, N
IF( K.GE.3 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
ELSE IF( K.EQ.2 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
INFO = K
RETURN
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
INFO = K
RETURN
END IF
END IF
Y( K ) = TEMP / AK
60 CONTINUE
ELSE
DO 80 K = 1, N
IF( K.GE.3 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
ELSE IF( K.EQ.2 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
PERT = SIGN( TOL, AK )
70 CONTINUE
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 70
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 70
END IF
END IF
Y( K ) = TEMP / AK
80 CONTINUE
END IF
*
DO 90 K = N, 2, -1
IF( IN( K-1 ).EQ.0 ) THEN
Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K )
ELSE
TEMP = Y( K-1 )
Y( K-1 ) = Y( K )
Y( K ) = TEMP - C( K-1 )*Y( K )
END IF
90 CONTINUE
END IF
*
* END OF DLAGTS
*
END
CUT HERE............
CAT > DLAGTF.F <<'CUT HERE............'
SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
INTEGER INFO, N
DOUBLE PRECISION LAMBDA, TOL
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IN( * )
DOUBLE PRECISION A( * ), B( * ), C( * ), D( * )
* ..
*
* PURPOSE
* =======
*
* DLAGTF FACTORIZES THE MATRIX (T - LAMBDA*I), WHERE T IS AN N BY N
* TRIDIAGONAL MATRIX AND LAMBDA IS A SCALAR, AS
*
* T - LAMBDA*I = PLU,
*
* WHERE P IS A PERMUTATION MATRIX, L IS A UNIT LOWER TRIDIAGONAL MATRIX
* WITH AT MOST ONE NON-ZERO SUB-DIAGONAL ELEMENTS PER COLUMN AND U IS
* AN UPPER TRIANGULAR MATRIX WITH AT MOST TWO NON-ZERO SUPER-DIAGONAL
* ELEMENTS PER COLUMN.
*
* THE FACTORIZATION IS OBTAINED BY GAUSSIAN ELIMINATION WITH PARTIAL
* PIVOTING AND IMPLICIT ROW SCALING.
*
* THE PARAMETER LAMBDA IS INCLUDED IN THE ROUTINE SO THAT DLAGTF MAY
* BE USED, IN CONJUNCTION WITH DLAGTS, TO OBTAIN EIGENVECTORS OF T BY
* INVERSE ITERATION.
*
* ARGUMENTS
* =========
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX T.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* ON ENTRY, A MUST CONTAIN THE DIAGONAL ELEMENTS OF T.
*
* ON EXIT, A IS OVERWRITTEN BY THE N DIAGONAL ELEMENTS OF THE
* UPPER TRIANGULAR MATRIX U OF THE FACTORIZATION OF T.
*
* LAMBDA (INPUT) DOUBLE PRECISION
* ON ENTRY, THE SCALAR LAMBDA.
*
* B (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* ON ENTRY, B MUST CONTAIN THE (N-1) SUPER-DIAGONAL ELEMENTS OF
* T.
*
* ON EXIT, B IS OVERWRITTEN BY THE (N-1) SUPER-DIAGONAL
* ELEMENTS OF THE MATRIX U OF THE FACTORIZATION OF T.
*
* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* ON ENTRY, C MUST CONTAIN THE (N-1) SUB-DIAGONAL ELEMENTS OF
* T.
*
* ON EXIT, C IS OVERWRITTEN BY THE (N-1) SUB-DIAGONAL ELEMENTS
* OF THE MATRIX L OF THE FACTORIZATION OF T.
*
* TOL (INPUT) DOUBLE PRECISION
* ON ENTRY, A RELATIVE TOLERANCE USED TO INDICATE WHETHER OR
* NOT THE MATRIX (T - LAMBDA*I) IS NEARLY SINGULAR. TOL SHOULD
* NORMALLY BE CHOSE AS APPROXIMATELY THE LARGEST RELATIVE ERROR
* IN THE ELEMENTS OF T. FOR EXAMPLE, IF THE ELEMENTS OF T ARE
* CORRECT TO ABOUT 4 SIGNIFICANT FIGURES, THEN TOL SHOULD BE
* SET TO ABOUT 5*10**(-4). IF TOL IS SUPPLIED AS LESS THAN EPS,
* WHERE EPS IS THE RELATIVE MACHINE PRECISION, THEN THE VALUE
* EPS IS USED IN PLACE OF TOL.
*
* D (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-2)
* ON EXIT, D IS OVERWRITTEN BY THE (N-2) SECOND SUPER-DIAGONAL
* ELEMENTS OF THE MATRIX U OF THE FACTORIZATION OF T.
*
* IN (OUTPUT) INTEGER ARRAY, DIMENSION (N)
* ON EXIT, IN CONTAINS DETAILS OF THE PERMUTATION MATRIX P. IF
* AN INTERCHANGE OCCURRED AT THE KTH STEP OF THE ELIMINATION,
* THEN IN(K) = 1, OTHERWISE IN(K) = 0. THE ELEMENT IN(N)
* RETURNS THE SMALLEST POSITIVE INTEGER J SUCH THAT
*
* ABS( U(J,J) ).LE. NORM( (T - LAMBDA*I)(J) )*TOL,
*
* WHERE NORM( A(J) ) DENOTES THE SUM OF THE ABSOLUTE VALUES OF
* THE JTH ROW OF THE MATRIX A. IF NO SUCH J EXISTS THEN IN(N)
* IS RETURNED AS ZERO. IF IN(N) IS RETURNED AS POSITIVE, THEN A
* DIAGONAL ELEMENT OF U IS SMALL, INDICATING THAT
* (T - LAMBDA*I) IS SINGULAR OR NEARLY SINGULAR,
*
* INFO (OUTPUT)
* = 0 : SUCCESSFUL EXIT
* .LT. 0: IF INFO = -K, THE KTH ARGUMENT HAD AN ILLEGAL VALUE
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER K
DOUBLE PRECISION EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, MAX
* ..
* .. EXTERNAL FUNCTIONS ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL XERBLA
* ..
* .. EXECUTABLE STATEMENTS ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DLAGTF', -INFO )
RETURN
END IF
*
IF( N.EQ.0 )
$ RETURN
*
A( 1 ) = A( 1 ) - LAMBDA
IN( N ) = 0
IF( N.EQ.1 ) THEN
IF( A( 1 ).EQ.ZERO )
$ IN( 1 ) = 1
RETURN
END IF
*
EPS = DLAMCH( 'EPSILON' )
*
TL = MAX( TOL, EPS )
SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) )
DO 10 K = 1, N - 1
A( K+1 ) = A( K+1 ) - LAMBDA
SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) )
IF( K.LT.( N-1 ) )
$ SCALE2 = SCALE2 + ABS( B( K+1 ) )
IF( A( K ).EQ.ZERO ) THEN
PIV1 = ZERO
ELSE
PIV1 = ABS( A( K ) ) / SCALE1
END IF
IF( C( K ).EQ.ZERO ) THEN
IN( K ) = 0
PIV2 = ZERO
SCALE1 = SCALE2
IF( K.LT.( N-1 ) )
$ D( K ) = ZERO
ELSE
PIV2 = ABS( C( K ) ) / SCALE2
IF( PIV2.LE.PIV1 ) THEN
IN( K ) = 0
SCALE1 = SCALE2
C( K ) = C( K ) / A( K )
A( K+1 ) = A( K+1 ) - C( K )*B( K )
IF( K.LT.( N-1 ) )
$ D( K ) = ZERO
ELSE
IN( K ) = 1
MULT = A( K ) / C( K )
A( K ) = C( K )
TEMP = A( K+1 )
A( K+1 ) = B( K ) - MULT*TEMP
IF( K.LT.( N-1 ) ) THEN
D( K ) = B( K+1 )
B( K+1 ) = -MULT*D( K )
END IF
B( K ) = TEMP
C( K ) = MULT
END IF
END IF
IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) )
$ IN( N ) = K
10 CONTINUE
IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) )
$ IN( N ) = N
*
RETURN
*
* END OF DLAGTF
*
END
CUT HERE............
CAT > DLARNV.F <<'CUT HERE............'
SUBROUTINE DLARNV( IDIST, ISEED, N, X )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
INTEGER IDIST, N
* ..
* .. ARRAY ARGUMENTS ..
INTEGER ISEED( 4 )
DOUBLE PRECISION X( * )
* ..
*
* PURPOSE
* =======
*
* DLARNV RETURNS A VECTOR OF N RANDOM REAL NUMBERS FROM A UNIFORM OR
* NORMAL DISTRIBUTION.
*
* ARGUMENTS
* =========
*
* IDIST (INPUT) INTEGER
* SPECIFIES THE DISTRIBUTION OF THE RANDOM NUMBERS:
* = 1: UNIFORM (0,1)
* = 2: UNIFORM (-1,1)
* = 3: NORMAL (0,1)
*
* ISEED (INPUT/OUTPUT) INTEGER ARRAY, DIMENSION (4)
* ON ENTRY, THE SEED OF THE RANDOM NUMBER GENERATOR; THE ARRAY
* ELEMENTS MUST BE BETWEEN 0 AND 4095, AND ISEED(4) MUST BE
* ODD.
* ON EXIT, THE SEED IS UPDATED.
*
* N (INPUT) INTEGER
* THE NUMBER OF RANDOM NUMBERS TO BE GENERATED.
*
* X (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* THE GENERATED RANDOM NUMBERS.
*
* FURTHER DETAILS
* ===============
*
* THIS ROUTINE CALLS THE AUXILIARY ROUTINE DLARUV TO GENERATE RANDOM
* REAL NUMBERS FROM A UNIFORM (0,1) DISTRIBUTION, IN BATCHES OF UP TO
* 128 USING VECTORISABLE CODE. THE BOX-MULLER METHOD IS USED TO
* TRANSFORM NUMBERS FROM A UNIFORM TO A NORMAL DISTRIBUTION.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, TWO
PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 )
INTEGER LV
PARAMETER ( LV = 128 )
DOUBLE PRECISION TWOPI
PARAMETER ( TWOPI = 6.28318530717958623199592D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, IL, IL2, IV
* ..
* .. LOCAL ARRAYS ..
DOUBLE PRECISION U( LV )
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC COS, LOG, MIN, SQRT
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLARUV
* ..
* .. EXECUTABLE STATEMENTS ..
*
DO 40 IV = 1, N, LV / 2
IL = MIN( LV / 2, N-IV+1 )
IF( IDIST.EQ.3 ) THEN
IL2 = 2*IL
ELSE
IL2 = IL
END IF
*
* CALL DLARUV TO GENERATE IL2 NUMBERS FROM A UNIFORM (0,1)
* DISTRIBUTION (IL2 <= LV)
*
CALL DLARUV( ISEED, IL2, U )
*
IF( IDIST.EQ.1 ) THEN
*
* COPY GENERATED NUMBERS
*
DO 10 I = 1, IL
X( IV+I-1 ) = U( I )
10 CONTINUE
ELSE IF( IDIST.EQ.2 ) THEN
*
* CONVERT GENERATED NUMBERS TO UNIFORM (-1,1) DISTRIBUTION
*
DO 20 I = 1, IL
X( IV+I-1 ) = TWO*U( I ) - ONE
20 CONTINUE
ELSE IF( IDIST.EQ.3 ) THEN
*
* CONVERT GENERATED NUMBERS TO NORMAL (0,1) DISTRIBUTION
*
DO 30 I = 1, IL
X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )*
$ COS( TWOPI*U( 2*I ) )
30 CONTINUE
END IF
40 CONTINUE
RETURN
*
* END OF DLARNV
*
END
CUT HERE............
CAT > DLARUV.F <<'CUT HERE............'
SUBROUTINE DLARUV( ISEED, N, X )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
INTEGER N
* ..
* .. ARRAY ARGUMENTS ..
INTEGER ISEED( 4 )
DOUBLE PRECISION X( N )
* ..
*
* PURPOSE
* =======
*
* DLARUV RETURNS A VECTOR OF N RANDOM REAL NUMBERS FROM A UNIFORM (0,1)
* DISTRIBUTION (N <= 128).
*
* THIS IS AN AUXILIARY ROUTINE CALLED BY DLARNV AND ZLARNV.
*
* ARGUMENTS
* =========
*
* ISEED (INPUT/OUTPUT) INTEGER ARRAY, DIMENSION (4)
* ON ENTRY, THE SEED OF THE RANDOM NUMBER GENERATOR; THE ARRAY
* ELEMENTS MUST BE BETWEEN 0 AND 4095, AND ISEED(4) MUST BE
* ODD.
* ON EXIT, THE SEED IS UPDATED.
*
* N (INPUT) INTEGER
* THE NUMBER OF RANDOM NUMBERS TO BE GENERATED. N <= 128.
*
* X (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* THE GENERATED RANDOM NUMBERS.
*
* FURTHER DETAILS
* ===============
*
* THIS ROUTINE USES A MULTIPLICATIVE CONGRUENTIAL METHOD WITH MODULUS
* 2**48 AND MULTIPLIER 33952834046453 (SEE G.S.FISHMAN,
* 'MULTIPLICATIVE CONGRUENTIAL RANDOM NUMBER GENERATORS WITH MODULUS
* 2**B: AN EXHAUSTIVE ANALYSIS FOR B = 32 AND A PARTIAL ANALYSIS FOR
* B = 48', MATH. COMP. 189, PP 331-344, 1990).
*
* 48-BIT INTEGERS ARE STORED IN 4 INTEGER ARRAY ELEMENTS WITH 12 BITS
* PER ELEMENT. HENCE THE ROUTINE IS PORTABLE ACROSS MACHINES WITH
* INTEGERS OF 32 BITS OR MORE.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
INTEGER LV, IPW2
DOUBLE PRECISION R
PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J
* ..
* .. LOCAL ARRAYS ..
INTEGER MM( LV, 4 )
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC DBLE, MIN, MOD
* ..
* .. DATA STATEMENTS ..
DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508,
$ 2549 /
DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754,
$ 1145 /
DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766,
$ 2253 /
DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572,
$ 305 /
DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893,
$ 3301 /
DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307,
$ 1065 /
DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297,
$ 3133 /
DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966,
$ 2913 /
DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758,
$ 3285 /
DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598,
$ 1241 /
DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406,
$ 1197 /
DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922,
$ 3729 /
DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038,
$ 2501 /
DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934,
$ 1673 /
DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091,
$ 541 /
DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451,
$ 2753 /
DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580,
$ 949 /
DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958,
$ 2361 /
DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055,
$ 1165 /
DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507,
$ 4081 /
DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078,
$ 2725 /
DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273,
$ 3305 /
DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17,
$ 3069 /
DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854,
$ 3617 /
DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916,
$ 3733 /
DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971,
$ 409 /
DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889,
$ 2157 /
DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831,
$ 1361 /
DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621,
$ 3973 /
DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541,
$ 1865 /
DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893,
$ 2525 /
DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736,
$ 1409 /
DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992,
$ 3445 /
DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787,
$ 3577 /
DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125,
$ 77 /
DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364,
$ 3761 /
DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460,
$ 2149 /
DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257,
$ 1449 /
DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574,
$ 3005 /
DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912,
$ 225 /
DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216,
$ 85 /
DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248,
$ 3673 /
DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401,
$ 3117 /
DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124,
$ 3089 /
DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762,
$ 1349 /
DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149,
$ 2057 /
DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245,
$ 413 /
DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166,
$ 65 /
DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466,
$ 1845 /
DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018,
$ 697 /
DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399,
$ 3085 /
DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190,
$ 3441 /
DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879,
$ 1573 /
DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153,
$ 3689 /
DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320,
$ 2941 /
DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18,
$ 929 /
DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712,
$ 533 /
DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159,
$ 2841 /
DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318,
$ 4077 /
DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091,
$ 721 /
DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443,
$ 2821 /
DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510,
$ 2249 /
DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449,
$ 2397 /
DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956,
$ 2817 /
DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201,
$ 245 /
DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137,
$ 1913 /
DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399,
$ 1997 /
DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321,
$ 3121 /
DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271,
$ 997 /
DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667,
$ 1833 /
DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703,
$ 2877 /
DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629,
$ 1633 /
DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365,
$ 981 /
DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431,
$ 2009 /
DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113,
$ 941 /
DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922,
$ 2449 /
DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554,
$ 197 /
DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184,
$ 2441 /
DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099,
$ 285 /
DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228,
$ 1473 /
DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012,
$ 2741 /
DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921,
$ 3129 /
DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452,
$ 909 /
DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901,
$ 2801 /
DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572,
$ 421 /
DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309,
$ 4073 /
DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171,
$ 2813 /
DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817,
$ 2337 /
DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039,
$ 1429 /
DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696,
$ 1177 /
DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256,
$ 1901 /
DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715,
$ 81 /
DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077,
$ 1669 /
DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019,
$ 2633 /
DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497,
$ 2269 /
DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101,
$ 129 /
DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717,
$ 1141 /
DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51,
$ 249 /
DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981,
$ 3917 /
DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978,
$ 2481 /
DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813,
$ 3941 /
DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881,
$ 2217 /
DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76,
$ 2749 /
DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846,
$ 3041 /
DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694,
$ 1877 /
DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682,
$ 345 /
DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124,
$ 2861 /
DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660,
$ 1809 /
DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997,
$ 3141 /
DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479,
$ 2825 /
DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141,
$ 157 /
DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886,
$ 2881 /
DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514,
$ 3637 /
DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301,
$ 1465 /
DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604,
$ 2829 /
DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888,
$ 2161 /
DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836,
$ 3365 /
DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990,
$ 361 /
DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058,
$ 2685 /
DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692,
$ 3745 /
DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194,
$ 2325 /
DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20,
$ 3609 /
DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285,
$ 3821 /
DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046,
$ 3537 /
DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107,
$ 517 /
DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508,
$ 3017 /
DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525,
$ 2141 /
DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801,
$ 1537 /
* ..
* .. EXECUTABLE STATEMENTS ..
*
I1 = ISEED( 1 )
I2 = ISEED( 2 )
I3 = ISEED( 3 )
I4 = ISEED( 4 )
*
DO 10 I = 1, MIN( N, LV )
*
* MULTIPLY THE SEED BY I-TH POWER OF THE MULTIPLIER MODULO 2**48
*
IT4 = I4*MM( I, 4 )
IT3 = IT4 / IPW2
IT4 = IT4 - IPW2*IT3
IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 )
IT2 = IT3 / IPW2
IT3 = IT3 - IPW2*IT2
IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 )
IT1 = IT2 / IPW2
IT2 = IT2 - IPW2*IT1
IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) +
$ I4*MM( I, 1 )
IT1 = MOD( IT1, IPW2 )
*
* CONVERT 48-BIT INTEGER TO A REAL NUMBER IN THE INTERVAL (0,1)
*
X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R*
$ DBLE( IT4 ) ) ) )
10 CONTINUE
*
* RETURN FINAL VALUE OF SEED
*
ISEED( 1 ) = IT1
ISEED( 2 ) = IT2
ISEED( 3 ) = IT3
ISEED( 4 ) = IT4
RETURN
*
* END OF DLARUV
*
END
CUT HERE............
CAT > DSTEBZ.F <<'CUT HERE............'
SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
$ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
$ INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
CHARACTER ORDER, RANGE
INTEGER IL, INFO, IU, M, N, NSPLIT
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
* ..
*
* PURPOSE
* =======
*
* DSTEBZ COMPUTES THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL
* MATRIX T. THE USER MAY ASK FOR ALL EIGENVALUES, ALL EIGENVALUES
* IN THE HALF-OPEN INTERVAL (VL, VU], OR THE IL-TH THROUGH IU-TH
* EIGENVALUES.
*
* SEE W. KAHAN "ACCURATE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL
* MATRIX", REPORT CS41, COMPUTER SCIENCE DEPT., STANFORD
* UNIVERSITY, JULY 21, 1966.
*
* ARGUMENTS
* =========
*
* RANGE (INPUT) CHARACTER
* = 'A': ("ALL") ALL EIGENVALUES WILL BE FOUND.
* = 'V': ("VALUE") ALL EIGENVALUES IN THE HALF-OPEN INTERVAL
* (VL, VU] WILL BE FOUND.
* = 'I': ("INDEX") THE IL-TH THROUGH IU-TH EIGENVALUES (OF THE
* ENTIRE MATRIX) WILL BE FOUND.
*
* ORDER (INPUT) CHARACTER
* = 'B': ("BY BLOCK") THE EIGENVALUES WILL BE GROUPED BY
* SPLIT-OFF BLOCK (SEE IBLOCK, ISPLIT) AND
* ORDERED FROM SMALLEST TO LARGEST WITHIN
* THE BLOCK.
* = 'E': ("ENTIRE MATRIX")
* THE EIGENVALUES FOR THE ENTIRE MATRIX
* WILL BE ORDERED FROM SMALLEST TO
* LARGEST.
*
* N (INPUT) INTEGER
* THE DIMENSION OF THE TRIDIAGONAL MATRIX T. N >= 0.
*
* VL (INPUT) DOUBLE PRECISION
* IF RANGE='V', THE LOWER BOUND OF THE INTERVAL TO BE SEARCHED
* FOR EIGENVALUES. EIGENVALUES LESS THAN OR EQUAL TO VL WILL
* NOT BE RETURNED. NOT REFERENCED IF RANGE='A' OR 'I'.
*
* VU (INPUT) DOUBLE PRECISION
* IF RANGE='V', THE UPPER BOUND OF THE INTERVAL TO BE SEARCHED
* FOR EIGENVALUES. EIGENVALUES GREATER THAN VU WILL NOT BE
* RETURNED. VU MUST BE GREATER THAN VL. NOT REFERENCED IF
* RANGE='A' OR 'I'.
*
* IL (INPUT) INTEGER
* IF RANGE='I', THE INDEX (FROM SMALLEST TO LARGEST) OF THE
* SMALLEST EIGENVALUE TO BE RETURNED. IL MUST BE AT LEAST 1.
* NOT REFERENCED IF RANGE='A' OR 'V'.
*
* IU (INPUT) INTEGER
* IF RANGE='I', THE INDEX (FROM SMALLEST TO LARGEST) OF THE
* LARGEST EIGENVALUE TO BE RETURNED. IU MUST BE AT LEAST IL
* AND NO GREATER THAN N. NOT REFERENCED IF RANGE='A' OR 'V'.
*
* ABSTOL (INPUT) DOUBLE PRECISION
* THE ABSOLUTE TOLERANCE FOR THE EIGENVALUES. AN EIGENVALUE
* (OR CLUSTER) IS CONSIDERED TO BE LOCATED IF IT HAS BEEN
* DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS ABSTOL OR
* LESS. IF ABSTOL IS LESS THAN OR EQUAL TO ZERO, THEN ULP*|T|
* WILL BE USED, WHERE |T| MEANS THE 1-NORM OF T.
*
* D (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* THE N DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T. TO
* AVOID OVERFLOW, THE MATRIX MUST BE SCALED SO THAT ITS LARGEST
* ENTRY IS NO GREATER THAN OVERFLOW**(1/2) * UNDERFLOW**(1/4)
* IN ABSOLUTE VALUE, AND FOR GREATEST ACCURACY, IT SHOULD NOT
* BE MUCH SMALLER THAN THAT.
*
* E (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* THE (N-1) OFF-DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T.
* TO AVOID OVERFLOW, THE MATRIX MUST BE SCALED SO THAT ITS
* LARGEST ENTRY IS NO GREATER THAN OVERFLOW**(1/2) *
* UNDERFLOW**(1/4) IN ABSOLUTE VALUE, AND FOR GREATEST
* ACCURACY, IT SHOULD NOT BE MUCH SMALLER THAN THAT.
*
* M (OUTPUT) INTEGER
* THE ACTUAL NUMBER OF EIGENVALUES FOUND. 0 <= M <= N.
* (SEE ALSO THE DESCRIPTION OF INFO=2,3.)
*
* NSPLIT (OUTPUT) INTEGER
* THE NUMBER OF DIAGONAL BLOCKS IN THE MATRIX T.
* 1 <= NSPLIT <= N.
*
* W (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* ON EXIT, THE FIRST M ELEMENTS OF W WILL CONTAIN THE
* EIGENVALUES. (DSTEBZ MAY USE THE REMAINING N-M ELEMENTS AS
* WORKSPACE.)
*
* IBLOCK (OUTPUT) INTEGER ARRAY, DIMENSION (N)
* AT EACH ROW/COLUMN J WHERE E(J) IS ZERO OR SMALL, THE
* MATRIX T IS CONSIDERED TO SPLIT INTO A BLOCK DIAGONAL
* MATRIX. ON EXIT, IBLOCK(I) SPECIFIES WHICH BLOCK (FROM 1 TO
* THE NUMBER OF BLOCKS) THE EIGENVALUE W(I) BELONGS TO.
* (DSTEBZ MAY USE THE REMAINING N-M ELEMENTS AS WORKSPACE.)
*
* ISPLIT (OUTPUT) INTEGER ARRAY, DIMENSION (N)
* THE SPLITTING POINTS, AT WHICH T BREAKS UP INTO SUBMATRICES.
* THE FIRST SUBMATRIX CONSISTS OF ROWS/COLUMNS 1 TO ISPLIT(1),
* THE SECOND OF ROWS/COLUMNS ISPLIT(1)+1 THROUGH ISPLIT(2),
* ETC., AND THE NSPLIT-TH CONSISTS OF ROWS/COLUMNS
* ISPLIT(NSPLIT-1)+1 THROUGH ISPLIT(NSPLIT)=N.
* (ONLY THE FIRST NSPLIT ELEMENTS WILL ACTUALLY BE USED, BUT
* SINCE THE USER CANNOT KNOW A PRIORI WHAT VALUE NSPLIT WILL
* HAVE, N WORDS MUST BE RESERVED FOR ISPLIT.)
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (4*N)
*
* IWORK (WORKSPACE) INTEGER ARRAY, DIMENSION (3*N)
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
* > 0: SOME OR ALL OF THE EIGENVALUES FAILED TO CONVERGE OR
* WERE NOT COMPUTED:
* =1 OR 3: BISECTION FAILED TO CONVERGE FOR SOME
* EIGENVALUES; THESE EIGENVALUES ARE FLAGGED BY A
* NEGATIVE BLOCK NUMBER. THE EFFECT IS THAT THE
* EIGENVALUES MAY NOT BE AS ACCURATE AS THE
* ABSOLUTE AND RELATIVE TOLERANCES. THIS IS
* GENERALLY CAUSED BY UNEXPECTEDLY INACCURATE
* ARITHMETIC.
* =2 OR 3: RANGE='I' ONLY: NOT ALL OF THE EIGENVALUES
* IL:IU WERE FOUND.
* EFFECT: M < IU+1-IL
* CAUSE: NON-MONOTONIC ARITHMETIC, CAUSING THE
* STURM SEQUENCE TO BE NON-MONOTONIC.
* CURE: RECALCULATE, USING RANGE='A', AND PICK
* OUT EIGENVALUES IL:IU. IN SOME CASES,
* INCREASING THE PARAMETER "FUDGE" MAY
* MAKE THINGS WORK.
* = 4: RANGE='I', AND THE GERSHGORIN INTERVAL
* INITIALLY USED WAS TOO SMALL. NO EIGENVALUES
* WERE COMPUTED.
* PROBABLE CAUSE: YOUR MACHINE HAS SLOPPY
* FLOATING-POINT ARITHMETIC.
* CURE: INCREASE THE PARAMETER "FUDGE",
* RECOMPILE, AND TRY AGAIN.
*
* INTERNAL PARAMETERS
* ===================
*
* RELFAC DOUBLE PRECISION, DEFAULT = 2.0E0
* THE RELATIVE TOLERANCE. AN INTERVAL (A,B] LIES WITHIN
* "RELATIVE TOLERANCE" IF B-A < RELFAC*ULP*MAX(|A|,|B|),
* WHERE "ULP" IS THE MACHINE PRECISION (DISTANCE FROM 1 TO
* THE NEXT LARGER FLOATING POINT NUMBER.)
*
* FUDGE DOUBLE PRECISION, DEFAULT = 2
* A "FUDGE FACTOR" TO WIDEN THE GERSHGORIN INTERVALS. IDEALLY,
* A VALUE OF 1 SHOULD WORK, BUT ON MACHINES WITH SLOPPY
* ARITHMETIC, THIS NEEDS TO BE LARGER. THE DEFAULT FOR
* PUBLICLY RELEASED VERSIONS SHOULD BE LARGE ENOUGH TO HANDLE
* THE WORST MACHINE AROUND. NOTE THAT THIS HAS NO EFFECT
* ON ACCURACY OF THE SOLUTION.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO, ONE, TWO, HALF
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ HALF = 1.0D0 / TWO )
DOUBLE PRECISION FUDGE, RELFAC
PARAMETER ( FUDGE = 2.0D0, RELFAC = 2.0D0 )
* ..
* .. LOCAL SCALARS ..
LOGICAL NCNVRG, TOOFEW
INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
$ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
$ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
$ NWU
DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
$ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
* ..
* .. LOCAL ARRAYS ..
INTEGER IDUMMA( 1 )
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, ILAENV, DLAMCH
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLAEBZ, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
* ..
* .. EXECUTABLE STATEMENTS ..
*
INFO = 0
*
* DECODE RANGE
*
IF( LSAME( RANGE, 'A' ) ) THEN
IRANGE = 1
ELSE IF( LSAME( RANGE, 'V' ) ) THEN
IRANGE = 2
ELSE IF( LSAME( RANGE, 'I' ) ) THEN
IRANGE = 3
ELSE
IRANGE = 0
END IF
*
* DECODE ORDER
*
IF( LSAME( ORDER, 'B' ) ) THEN
IORDER = 2
ELSE IF( LSAME( ORDER, 'E' ) .OR. LSAME( ORDER, 'A' ) ) THEN
IORDER = 1
ELSE
IORDER = 0
END IF
*
* CHECK FOR ERRORS
*
IF( IRANGE.LE.0 ) THEN
INFO = -1
ELSE IF( IORDER.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( IRANGE.EQ.2 .AND. VL.GE.VU ) THEN
INFO = -5
ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
$ THEN
INFO = -6
ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
$ THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEBZ', -INFO )
RETURN
END IF
*
* INITIALIZE ERROR FLAGS
*
INFO = 0
NCNVRG = .FALSE.
TOOFEW = .FALSE.
*
* QUICK RETURN IF POSSIBLE
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
* SIMPLIFICATIONS:
*
IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N )
$ IRANGE = 1
*
* GET MACHINE CONSTANTS
* NB IS THE MINIMUM VECTOR LENGTH FOR VECTOR BISECTION, OR 0
* IF ONLY SCALAR IS TO BE DONE.
*
SAFEMN = DLAMCH( 'S' )
ULP = DLAMCH( 'P' )
RTOLI = ULP*RELFAC
NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 )
IF( NB.LE.1 )
$ NB = 0
*
* SPECIAL CASE WHEN N=1
*
IF( N.EQ.1 ) THEN
NSPLIT = 1
ISPLIT( 1 ) = 1
IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN
M = 0
ELSE
W( 1 ) = D( 1 )
IBLOCK( 1 ) = 1
M = 1
END IF
RETURN
END IF
*
* COMPUTE SPLITTING POINTS
*
NSPLIT = 1
WORK( N ) = ZERO
PIVMIN = ONE
*
DO 10 J = 2, N
TMP1 = E( J-1 )**2
IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN
ISPLIT( NSPLIT ) = J - 1
NSPLIT = NSPLIT + 1
WORK( J-1 ) = ZERO
ELSE
WORK( J-1 ) = TMP1
PIVMIN = MAX( PIVMIN, TMP1 )
END IF
10 CONTINUE
ISPLIT( NSPLIT ) = N
PIVMIN = PIVMIN*SAFEMN
*
* COMPUTE INTERVAL AND ATOLI
*
IF( IRANGE.EQ.3 ) THEN
*
* RANGE='I': COMPUTE THE INTERVAL CONTAINING EIGENVALUES
* IL THROUGH IU.
*
* COMPUTE GERSHGORIN INTERVAL FOR ENTIRE (SPLIT) MATRIX
* AND USE IT AS THE INITIAL INTERVAL
*
GU = D( 1 )
GL = D( 1 )
TMP1 = ZERO
*
DO 20 J = 1, N - 1
TMP2 = SQRT( WORK( J ) )
GU = MAX( GU, D( J )+TMP1+TMP2 )
GL = MIN( GL, D( J )-TMP1-TMP2 )
TMP1 = TMP2
20 CONTINUE
*
GU = MAX( GU, D( N )+TMP1 )
GL = MIN( GL, D( N )-TMP1 )
TNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
*
* COMPUTE ITERATION PARAMETERS
*
ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*TNORM
ELSE
ATOLI = ABSTOL
END IF
*
WORK( N+1 ) = GL
WORK( N+2 ) = GL
WORK( N+3 ) = GU
WORK( N+4 ) = GU
WORK( N+5 ) = GL
WORK( N+6 ) = GU
IWORK( 1 ) = -1
IWORK( 2 ) = -1
IWORK( 3 ) = N + 1
IWORK( 4 ) = N + 1
IWORK( 5 ) = IL - 1
IWORK( 6 ) = IU
*
CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
$ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
$ IWORK, W, IBLOCK, IINFO )
*
IF( IWORK( 6 ).EQ.IU ) THEN
WL = WORK( N+1 )
WLU = WORK( N+3 )
NWL = IWORK( 1 )
WU = WORK( N+4 )
WUL = WORK( N+2 )
NWU = IWORK( 4 )
ELSE
WL = WORK( N+2 )
WLU = WORK( N+4 )
NWL = IWORK( 2 )
WU = WORK( N+3 )
WUL = WORK( N+1 )
NWU = IWORK( 3 )
END IF
*
IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
INFO = 4
RETURN
END IF
ELSE
*
* RANGE='A' OR 'V' -- SET ATOLI
*
TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
$ ABS( D( N ) )+ABS( E( N-1 ) ) )
*
DO 30 J = 2, N - 1
TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+
$ ABS( E( J ) ) )
30 CONTINUE
*
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*TNORM
ELSE
ATOLI = ABSTOL
END IF
*
IF( IRANGE.EQ.2 ) THEN
WL = VL
WU = VU
END IF
END IF
*
* FIND EIGENVALUES -- LOOP OVER BLOCKS AND RECOMPUTE NWL AND NWU.
* NWL ACCUMULATES THE NUMBER OF EIGENVALUES .LE. WL,
* NWU ACCUMULATES THE NUMBER OF EIGENVALUES .LE. WU
*
M = 0
IEND = 0
INFO = 0
NWL = 0
NWU = 0
*
DO 70 JB = 1, NSPLIT
IOFF = IEND
IBEGIN = IOFF + 1
IEND = ISPLIT( JB )
IN = IEND - IOFF
*
IF( IN.EQ.1 ) THEN
*
* SPECIAL CASE -- IN=1
*
IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN )
$ NWL = NWL + 1
IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN )
$ NWU = NWU + 1
IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE.
$ D( IBEGIN )-PIVMIN ) ) THEN
M = M + 1
W( M ) = D( IBEGIN )
IBLOCK( M ) = JB
END IF
ELSE
*
* GENERAL CASE -- IN > 1
*
* COMPUTE GERSHGORIN INTERVAL
* AND USE IT AS THE INITIAL INTERVAL
*
GU = D( IBEGIN )
GL = D( IBEGIN )
TMP1 = ZERO
*
DO 40 J = IBEGIN, IEND - 1
TMP2 = ABS( E( J ) )
GU = MAX( GU, D( J )+TMP1+TMP2 )
GL = MIN( GL, D( J )-TMP1-TMP2 )
TMP1 = TMP2
40 CONTINUE
*
GU = MAX( GU, D( IEND )+TMP1 )
GL = MIN( GL, D( IEND )-TMP1 )
BNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN
GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN
*
IF( IRANGE.GT.1 ) THEN
GL = MAX( GL, WL )
GU = MIN( GU, WU )
IF( GL.GE.GU )
$ GO TO 70
END IF
*
* SET UP INITIAL INTERVAL
*
WORK( N+1 ) = GL
WORK( N+IN+1 ) = GU
CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
NWL = NWL + IWORK( 1 )
NWU = NWU + IWORK( IN+1 )
IWOFF = M - IWORK( 1 )
*
* COMPUTE EIGENVALUES
*
ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
* COPY EIGENVALUES INTO W AND IBLOCK
* USE -JB FOR BLOCK NUMBER FOR UNCONVERGED EIGENVALUES.
*
DO 60 J = 1, IOUT
TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
*
* FLAG NON-CONVERGENCE.
*
IF( J.GT.IOUT-IINFO ) THEN
NCNVRG = .TRUE.
IB = -JB
ELSE
IB = JB
END IF
DO 50 JE = IWORK( J ) + 1 + IWOFF,
$ IWORK( J+IN ) + IWOFF
W( JE ) = TMP1
IBLOCK( JE ) = IB
50 CONTINUE
60 CONTINUE
*
M = M + IM
END IF
70 CONTINUE
*
* IF RANGE='I', THEN (WL,WU) CONTAINS EIGENVALUES NWL+1,...,NWU
* IF NWL+1 < IL OR NWU > IU, DISCARD EXTRA EIGENVALUES.
*
IF( IRANGE.EQ.3 ) THEN
IM = 0
IDISCL = IL - 1 - NWL
IDISCU = NWU - IU
*
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
DO 80 JE = 1, M
IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
IDISCL = IDISCL - 1
ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
IDISCU = IDISCU - 1
ELSE
IM = IM + 1
W( IM ) = W( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
80 CONTINUE
M = IM
END IF
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
*
* CODE TO DEAL WITH EFFECTS OF BAD ARITHMETIC:
* SOME LOW EIGENVALUES TO BE DISCARDED ARE NOT IN (WL,WLU],
* OR HIGH EIGENVALUES TO BE DISCARDED ARE NOT IN (WUL,WU]
* SO JUST KILL OFF THE SMALLEST IDISCL/LARGEST IDISCU
* EIGENVALUES, BY SIMPLY FINDING THE SMALLEST/LARGEST
* EIGENVALUE(S).
*
* (IF N(W) IS MONOTONE NON-DECREASING, THIS SHOULD NEVER
* HAPPEN.)
*
IF( IDISCL.GT.0 ) THEN
WKILL = WU
DO 100 JDISC = 1, IDISCL
IW = 0
DO 90 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
90 CONTINUE
IBLOCK( IW ) = 0
100 CONTINUE
END IF
IF( IDISCU.GT.0 ) THEN
*
WKILL = WL
DO 120 JDISC = 1, IDISCU
IW = 0
DO 110 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
110 CONTINUE
IBLOCK( IW ) = 0
120 CONTINUE
END IF
IM = 0
DO 130 JE = 1, M
IF( IBLOCK( JE ).NE.0 ) THEN
IM = IM + 1
W( IM ) = W( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
130 CONTINUE
M = IM
END IF
IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
TOOFEW = .TRUE.
END IF
END IF
*
* IF ORDER='B', DO NOTHING -- THE EIGENVALUES ARE ALREADY SORTED
* BY BLOCK.
* IF ORDER='E' OR 'A', SORT THE EIGENVALUES FROM SMALLEST TO LARGEST
*
IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN
DO 150 JE = 1, M - 1
IE = 0
TMP1 = W( JE )
DO 140 J = JE + 1, M
IF( W( J ).LT.TMP1 ) THEN
IE = J
TMP1 = W( J )
END IF
140 CONTINUE
*
IF( IE.NE.0 ) THEN
ITMP1 = IBLOCK( IE )
W( IE ) = W( JE )
IBLOCK( IE ) = IBLOCK( JE )
W( JE ) = TMP1
IBLOCK( JE ) = ITMP1
END IF
150 CONTINUE
END IF
*
INFO = 0
IF( NCNVRG )
$ INFO = INFO + 1
IF( TOOFEW )
$ INFO = INFO + 2
RETURN
*
* END OF DSTEBZ
*
END
CUT HERE............
CAT > DLAEBZ.F <<'CUT HERE............'
SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL,
$ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT,
$ NAB, WORK, IWORK, INFO )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * )
DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
$ WORK( * )
* ..
*
* PURPOSE
* =======
*
* DLAEBZ CONTAINS THE ITERATION LOOPS WHICH COMPUTE AND USE THE
* FUNCTION N(W), WHICH IS THE COUNT OF EIGENVALUES OF A SYMMETRIC
* TRIDIAGONAL MATRIX T LESS THAN OR EQUAL TO ITS ARGUMENT W. IT
* PERFORMS A CHOICE OF TWO TYPES OF LOOPS:
*
* IJOB=1, FOLLOWED BY
* IJOB=2: IT TAKES AS INPUT A LIST OF INTERVALS AND RETURNS A LIST OF
* SUFFICIENTLY SMALL INTERVALS WHOSE UNION CONTAINS THE SAME
* EIGENVALUES AS THE UNION OF THE ORIGINAL INTERVALS.
* THE INPUT INTERVALS ARE (AB(J,1),AB(J,2)], J=1,...,MINP.
* THE OUTPUT INTERVAL (AB(J,1),AB(J,2)] WILL CONTAIN
* EIGENVALUES NAB(J,1)+1,...,NAB(J,2), WHERE 1 <= J <= MOUT.
*
* IJOB=3: IT PERFORMS A BINARY SEARCH IN EACH INPUT INTERVAL
* (AB(J,1),AB(J,2)] FOR A POINT W(J) SUCH THAT
* N(W(J))=NVAL(J), AND USES C(J) AS THE STARTING POINT OF
* THE SEARCH. IF SUCH A W(J) IS FOUND, THEN ON OUTPUT
* AB(J,1)=AB(J,2)=W. IF NO SUCH W(J) IS FOUND, THEN ON OUTPUT
* (AB(J,1),AB(J,2)] WILL BE A SMALL INTERVAL CONTAINING THE
* POINT WHERE N(W) JUMPS THROUGH NVAL(J), UNLESS THAT POINT
* LIES OUTSIDE THE INITIAL INTERVAL.
*
* NOTE THAT THE INTERVALS ARE IN ALL CASES HALF-OPEN INTERVALS,
* I.E., OF THE FORM (A,B] , WHICH INCLUDES B BUT NOT A .
*
* SEE W. KAHAN "ACCURATE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL
* MATRIX", REPORT CS41, COMPUTER SCIENCE DEPT., STANFORD
* UNIVERSITY, JULY 21, 1966
*
* NOTE: THE ARGUMENTS ARE, IN GENERAL, *NOT* CHECKED FOR UNREASONABLE
* VALUES.
*
* ARGUMENTS
* =========
*
* IJOB (INPUT) INTEGER
* SPECIFIES WHAT IS TO BE DONE:
* = 1: COMPUTE NAB FOR THE INITIAL INTERVALS.
* = 2: PERFORM BISECTION ITERATION TO FIND EIGENVALUES OF T.
* = 3: PERFORM BISECTION ITERATION TO INVERT N(W), I.E.,
* TO FIND A POINT WHICH HAS A SPECIFIED NUMBER OF
* EIGENVALUES OF T TO ITS LEFT.
* OTHER VALUES WILL CAUSE DLAEBZ TO RETURN WITH INFO=-1.
*
* NITMAX (INPUT) INTEGER
* THE MAXIMUM NUMBER OF "LEVELS" OF BISECTION TO BE
* PERFORMED, I.E., AN INTERVAL OF WIDTH W WILL NOT BE MADE
* SMALLER THAN 2^(-NITMAX) * W. IF NOT ALL INTERVALS
* HAVE CONVERGED AFTER NITMAX ITERATIONS, THEN INFO IS SET
* TO THE NUMBER OF NON-CONVERGED INTERVALS.
*
* N (INPUT) INTEGER
* THE DIMENSION N OF THE TRIDIAGONAL MATRIX T. IT MUST BE AT
* LEAST 1.
*
* MMAX (INPUT) INTEGER
* THE MAXIMUM NUMBER OF INTERVALS. IF MORE THAN MMAX INTERVALS
* ARE GENERATED, THEN DLAEBZ WILL QUIT WITH INFO=MMAX+1.
*
* MINP (INPUT) INTEGER
* THE INITIAL NUMBER OF INTERVALS. IT MAY NOT BE GREATER THAN
* MMAX.
*
* NBMIN (INPUT) INTEGER
* THE SMALLEST NUMBER OF INTERVALS THAT SHOULD BE PROCESSED
* USING A VECTOR LOOP. IF ZERO, THEN ONLY THE SCALAR LOOP
* WILL BE USED.
*
* ABSTOL (INPUT) DOUBLE PRECISION
* THE MINIMUM (ABSOLUTE) WIDTH OF AN INTERVAL. WHEN AN
* INTERVAL IS NARROWER THAN ABSTOL, OR THAN RELTOL TIMES THE
* LARGER (IN MAGNITUDE) ENDPOINT, THEN IT IS CONSIDERED TO BE
* SUFFICIENTLY SMALL, I.E., CONVERGED. THIS MUST BE AT LEAST
* ZERO.
*
* RELTOL (INPUT) DOUBLE PRECISION
* THE MINIMUM RELATIVE WIDTH OF AN INTERVAL. WHEN AN INTERVAL
* IS NARROWER THAN ABSTOL, OR THAN RELTOL TIMES THE LARGER (IN
* MAGNITUDE) ENDPOINT, THEN IT IS CONSIDERED TO BE
* SUFFICIENTLY SMALL, I.E., CONVERGED. NOTE: THIS SHOULD
* ALWAYS BE AT LEAST RADIX*MACHINE EPSILON.
*
* PIVMIN (INPUT) DOUBLE PRECISION
* THE MINIMUM ABSOLUTE VALUE OF A "PIVOT" IN THE STURM
* SEQUENCE LOOP. THIS *MUST* BE AT LEAST MAX |E(J)**2| *
* SAFE_MIN AND AT LEAST SAFE_MIN, WHERE SAFE_MIN IS AT LEAST
* THE SMALLEST NUMBER THAT CAN DIVIDE ONE WITHOUT OVERFLOW.
*
* D (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T. TO AVOID
* UNDERFLOW, THE MATRIX SHOULD BE SCALED SO THAT ITS LARGEST
* ENTRY IS NO GREATER THAN OVERFLOW**(1/2) * UNDERFLOW**(1/4)
* IN ABSOLUTE VALUE. TO ASSURE THE MOST ACCURATE COMPUTATION
* OF SMALL EIGENVALUES, THE MATRIX SHOULD BE SCALED TO BE
* NOT MUCH SMALLER THAN THAT, EITHER.
*
* E (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* THE OFFDIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T IN
* POSITIONS 1 THROUGH N-1. E(N) IS ARBITRARY.
* TO AVOID UNDERFLOW, THE
* MATRIX SHOULD BE SCALED SO THAT ITS LARGEST ENTRY IS NO
* GREATER THAN OVERFLOW**(1/2) * UNDERFLOW**(1/4) IN ABSOLUTE
* VALUE. TO ASSURE THE MOST ACCURATE COMPUTATION OF SMALL
* EIGENVALUES, THE MATRIX SHOULD BE SCALED TO BE NOT MUCH
* SMALLER THAN THAT, EITHER.
*
* E2 (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* THE SQUARES OF THE OFFDIAGONAL ELEMENTS OF THE TRIDIAGONAL
* MATRIX T. E2(N) IS IGNORED.
*
* NVAL (INPUT/OUTPUT) INTEGER ARRAY, DIMENSION (MINP)
* IF IJOB=1 OR 2, NOT REFERENCED.
* IF IJOB=3, THE DESIRED VALUES OF N(W). THE ELEMENTS OF NVAL
* WILL BE REORDERED TO CORRESPOND WITH THE INTERVALS IN AB.
* THUS, NVAL(J) ON OUTPUT WILL NOT, IN GENERAL BE THE SAME AS
* NVAL(J) ON INPUT, BUT IT WILL CORRESPOND WITH THE INTERVAL
* (AB(J,1),AB(J,2)] ON OUTPUT.
*
* AB (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (MMAX,2)
* THE ENDPOINTS OF THE INTERVALS. AB(J,1) IS A(J), THE LEFT
* ENDPOINT OF THE J-TH INTERVAL, AND AB(J,2) IS B(J), THE
* RIGHT ENDPOINT OF THE J-TH INTERVAL. THE INPUT INTERVALS
* WILL, IN GENERAL, BE MODIFIED, SPLIT, AND REORDERED BY THE
* CALCULATION.
*
* C (INPUT/WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (MMAX)
* IF IJOB=1, IGNORED.
* IF IJOB=2, WORKSPACE.
* IF IJOB=3, THEN ON INPUT C(J) SHOULD BE INITIALIZED TO THE
* FIRST SEARCH POINT IN THE BINARY SEARCH.
*
* MOUT (OUTPUT) INTEGER
* IF IJOB=1, THE NUMBER OF EIGENVALUES IN THE INTERVALS.
* IF IJOB=2 OR 3, THE NUMBER OF INTERVALS OUTPUT.
* IF IJOB=3, MOUT WILL EQUAL MINP.
*
* NAB (INPUT/OUTPUT) INTEGER ARRAY, DIMENSION (MMAX,2)
* IF IJOB=1, THEN ON OUTPUT NAB(I,J) WILL BE SET TO N(AB(I,J)).
* IF IJOB=2, THEN ON INPUT, NAB(I,J) SHOULD BE SET. IT MUST
* SATISFY THE CONDITION:
* N(AB(I,1)) <= NAB(I,1) <= NAB(I,2) <= N(AB(I,2)),
* WHICH MEANS THAT IN INTERVAL I ONLY EIGENVALUES
* NAB(I,1)+1,...,NAB(I,2) WILL BE CONSIDERED. USUALLY,
* NAB(I,J)=N(AB(I,J)), FROM A PREVIOUS CALL TO DLAEBZ WITH
* IJOB=1.
* ON OUTPUT, NAB(I,J) WILL CONTAIN
* MAX(NA(K),MIN(NB(K),N(AB(I,J)))), WHERE K IS THE INDEX OF
* THE INPUT INTERVAL THAT THE OUTPUT INTERVAL
* (AB(J,1),AB(J,2)] CAME FROM, AND NA(K) AND NB(K) ARE THE
* THE INPUT VALUES OF NAB(K,1) AND NAB(K,2).
* IF IJOB=3, THEN ON OUTPUT, NAB(I,J) CONTAINS N(AB(I,J)),
* UNLESS N(W) > NVAL(I) FOR ALL SEARCH POINTS W , IN WHICH
* CASE NAB(I,1) WILL NOT BE MODIFIED, I.E., THE OUTPUT
* VALUE WILL BE THE SAME AS THE INPUT VALUE (MODULO
* REORDERINGS -- SEE NVAL AND AB), OR UNLESS N(W) < NVAL(I)
* FOR ALL SEARCH POINTS W , IN WHICH CASE NAB(I,2) WILL
* NOT BE MODIFIED. NORMALLY, NAB SHOULD BE SET TO SOME
* DISTINCTIVE VALUE(S) BEFORE DLAEBZ IS CALLED.
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (MMAX)
* WORKSPACE.
*
* IWORK (WORKSPACE) INTEGER ARRAY, DIMENSION (MMAX)
* WORKSPACE.
*
* INFO (OUTPUT) INTEGER
* = 0: ALL INTERVALS CONVERGED.
* = 1--MMAX: THE LAST INFO INTERVALS DID NOT CONVERGE.
* = MMAX+1: MORE THAN MMAX INTERVALS WERE GENERATED.
*
* FURTHER DETAILS
* ===============
*
* THIS ROUTINE IS INTENDED TO BE CALLED ONLY BY OTHER LAPACK
* ROUTINES, THUS THE INTERFACE IS LESS USER-FRIENDLY. IT IS INTENDED
* FOR TWO PURPOSES:
*
* (A) FINDING EIGENVALUES. IN THIS CASE, DLAEBZ SHOULD HAVE ONE OR
* MORE INITIAL INTERVALS SET UP IN AB, AND DLAEBZ SHOULD BE CALLED
* WITH IJOB=1. THIS SETS UP NAB, AND ALSO COUNTS THE EIGENVALUES.
* INTERVALS WITH NO EIGENVALUES WOULD USUALLY BE THROWN OUT AT
* THIS POINT. ALSO, IF NOT ALL THE EIGENVALUES IN AN INTERVAL I
* ARE DESIRED, NAB(I,1) CAN BE INCREASED OR NAB(I,2) DECREASED.
* FOR EXAMPLE, SET NAB(I,1)=NAB(I,2)-1 TO GET THE LARGEST
* EIGENVALUE. DLAEBZ IS THEN CALLED WITH IJOB=2 AND MMAX
* NO SMALLER THAN THE VALUE OF MOUT RETURNED BY THE CALL WITH
* IJOB=1. AFTER THIS (IJOB=2) CALL, EIGENVALUES NAB(I,1)+1
* THROUGH NAB(I,2) ARE APPROXIMATELY AB(I,1) (OR AB(I,2)) TO THE
* TOLERANCE SPECIFIED BY ABSTOL AND RELTOL.
*
* (B) FINDING AN INTERVAL (A',B'] CONTAINING EIGENVALUES W(F),...,W(L).
* IN THIS CASE, START WITH A GERSHGORIN INTERVAL (A,B). SET UP
* AB TO CONTAIN 2 SEARCH INTERVALS, BOTH INITIALLY (A,B). ONE
* NVAL ENTRY SHOULD CONTAIN F-1 AND THE OTHER SHOULD CONTAIN L
* , WHILE C SHOULD CONTAIN A AND B, RESP. NAB(I,1) SHOULD BE -1
* AND NAB(I,2) SHOULD BE N+1, TO FLAG AN ERROR IF THE DESIRED
* INTERVAL DOES NOT LIE IN (A,B). DLAEBZ IS THEN CALLED WITH
* IJOB=3. ON EXIT, IF W(F-1) < W(F), THEN ONE OF THE INTERVALS --
* J -- WILL HAVE AB(J,1)=AB(J,2) AND NAB(J,1)=NAB(J,2)=F-1, WHILE
* IF, TO THE SPECIFIED TOLERANCE, W(F-K)=...=W(F+R), K > 0 AND R
* >= 0, THEN THE INTERVAL WILL HAVE N(AB(J,1))=NAB(J,1)=F-K AND
* N(AB(J,2))=NAB(J,2)=F+R. THE CASES W(L) < W(L+1) AND
* W(L-R)=...=W(L+K) ARE HANDLED SIMILARLY.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO, TWO, HALF
PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0,
$ HALF = 1.0D0 / TWO )
* ..
* .. LOCAL SCALARS ..
INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
$ KLNEW
DOUBLE PRECISION TMP1, TMP2
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, MAX, MIN
* ..
* .. EXECUTABLE STATEMENTS ..
*
* CHECK FOR ERRORS
*
INFO = 0
IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN
INFO = -1
RETURN
END IF
*
* INITIALIZE NAB
*
IF( IJOB.EQ.1 ) THEN
*
* COMPUTE THE NUMBER OF EIGENVALUES IN THE INITIAL INTERVALS.
*
MOUT = 0
DO 30 JI = 1, MINP
DO 20 JP = 1, 2
TMP1 = D( 1 ) - AB( JI, JP )
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
NAB( JI, JP ) = 0
IF( TMP1.LE.ZERO )
$ NAB( JI, JP ) = 1
*
DO 10 J = 2, N
TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP )
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
IF( TMP1.LE.ZERO )
$ NAB( JI, JP ) = NAB( JI, JP ) + 1
10 CONTINUE
20 CONTINUE
MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 )
30 CONTINUE
RETURN
END IF
*
* INITIALIZE FOR LOOP
*
* KF AND KL HAVE THE FOLLOWING MEANING:
* INTERVALS 1,...,KF-1 HAVE CONVERGED.
* INTERVALS KF,...,KL STILL NEED TO BE REFINED.
*
KF = 1
KL = MINP
*
* IF IJOB=2, INITIALIZE C.
* IF IJOB=3, USE THE USER-SUPPLIED STARTING POINT.
*
IF( IJOB.EQ.2 ) THEN
DO 40 JI = 1, MINP
C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
40 CONTINUE
END IF
*
* ITERATION LOOP
*
DO 130 JIT = 1, NITMAX
*
* LOOP OVER INTERVALS
*
IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN
*
* BEGIN OF PARALLEL VERSION OF THE LOOP
*
DO 60 JI = KF, KL
*
* COMPUTE N(C), THE NUMBER OF EIGENVALUES LESS THAN C
*
WORK( JI ) = D( 1 ) - C( JI )
IWORK( JI ) = 0
IF( WORK( JI ).LE.PIVMIN ) THEN
IWORK( JI ) = 1
WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
END IF
*
DO 50 J = 2, N
WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI )
IF( WORK( JI ).LE.PIVMIN ) THEN
IWORK( JI ) = IWORK( JI ) + 1
WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
END IF
50 CONTINUE
60 CONTINUE
*
IF( IJOB.LE.2 ) THEN
*
* IJOB=2: CHOOSE ALL INTERVALS CONTAINING EIGENVALUES.
*
KLNEW = KL
DO 70 JI = KF, KL
*
* INSURE THAT N(W) IS MONOTONE
*
IWORK( JI ) = MIN( NAB( JI, 2 ),
$ MAX( NAB( JI, 1 ), IWORK( JI ) ) )
*
* UPDATE THE QUEUE -- ADD INTERVALS IF BOTH HALVES
* CONTAIN EIGENVALUES.
*
IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN
*
* NO EIGENVALUE IN THE UPPER INTERVAL:
* JUST USE THE LOWER INTERVAL.
*
AB( JI, 2 ) = C( JI )
*
ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN
*
* NO EIGENVALUE IN THE LOWER INTERVAL:
* JUST USE THE UPPER INTERVAL.
*
AB( JI, 1 ) = C( JI )
ELSE
KLNEW = KLNEW + 1
IF( KLNEW.LE.MMAX ) THEN
*
* EIGENVALUE IN BOTH INTERVALS -- ADD UPPER TO
* QUEUE.
*
AB( KLNEW, 2 ) = AB( JI, 2 )
NAB( KLNEW, 2 ) = NAB( JI, 2 )
AB( KLNEW, 1 ) = C( JI )
NAB( KLNEW, 1 ) = IWORK( JI )
AB( JI, 2 ) = C( JI )
NAB( JI, 2 ) = IWORK( JI )
ELSE
INFO = MMAX + 1
END IF
END IF
70 CONTINUE
IF( INFO.NE.0 )
$ RETURN
KL = KLNEW
ELSE
*
* IJOB=3: BINARY SEARCH. KEEP ONLY THE INTERVAL CONTAINING
* W S.T. N(W) = NVAL
*
DO 80 JI = KF, KL
IF( IWORK( JI ).LE.NVAL( JI ) ) THEN
AB( JI, 1 ) = C( JI )
NAB( JI, 1 ) = IWORK( JI )
END IF
IF( IWORK( JI ).GE.NVAL( JI ) ) THEN
AB( JI, 2 ) = C( JI )
NAB( JI, 2 ) = IWORK( JI )
END IF
80 CONTINUE
END IF
*
ELSE
*
* END OF PARALLEL VERSION OF THE LOOP
*
* BEGIN OF SERIAL VERSION OF THE LOOP
*
KLNEW = KL
DO 100 JI = KF, KL
*
* COMPUTE N(W), THE NUMBER OF EIGENVALUES LESS THAN W
*
TMP1 = C( JI )
TMP2 = D( 1 ) - TMP1
ITMP1 = 0
IF( TMP2.LE.PIVMIN ) THEN
ITMP1 = 1
TMP2 = MIN( TMP2, -PIVMIN )
END IF
*
* A SERIES OF COMPILER DIRECTIVES TO DEFEAT VECTORIZATION
* FOR THE NEXT LOOP
*
*$PL$ CMCHAR=' '
CDIR$ NEXTSCALAR
C$DIR SCALAR
CDIR$ NEXT SCALAR
CVD$L NOVECTOR
CDEC$ NOVECTOR
CVD$ NOVECTOR
*VDIR NOVECTOR
*VOCL LOOP,SCALAR
CIBM PREFER SCALAR
*$PL$ CMCHAR='*'
*
DO 90 J = 2, N
TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1
IF( TMP2.LE.PIVMIN ) THEN
ITMP1 = ITMP1 + 1
TMP2 = MIN( TMP2, -PIVMIN )
END IF
90 CONTINUE
*
IF( IJOB.LE.2 ) THEN
*
* IJOB=2: CHOOSE ALL INTERVALS CONTAINING EIGENVALUES.
*
* INSURE THAT N(W) IS MONOTONE
*
ITMP1 = MIN( NAB( JI, 2 ),
$ MAX( NAB( JI, 1 ), ITMP1 ) )
*
* UPDATE THE QUEUE -- ADD INTERVALS IF BOTH HALVES
* CONTAIN EIGENVALUES.
*
IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN
*
* NO EIGENVALUE IN THE UPPER INTERVAL:
* JUST USE THE LOWER INTERVAL.
*
AB( JI, 2 ) = TMP1
*
ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN
*
* NO EIGENVALUE IN THE LOWER INTERVAL:
* JUST USE THE UPPER INTERVAL.
*
AB( JI, 1 ) = TMP1
ELSE IF( KLNEW.LT.MMAX ) THEN
*
* EIGENVALUE IN BOTH INTERVALS -- ADD UPPER TO QUEUE.
*
KLNEW = KLNEW + 1
AB( KLNEW, 2 ) = AB( JI, 2 )
NAB( KLNEW, 2 ) = NAB( JI, 2 )
AB( KLNEW, 1 ) = TMP1
NAB( KLNEW, 1 ) = ITMP1
AB( JI, 2 ) = TMP1
NAB( JI, 2 ) = ITMP1
ELSE
INFO = MMAX + 1
RETURN
END IF
ELSE
*
* IJOB=3: BINARY SEARCH. KEEP ONLY THE INTERVAL
* CONTAINING W S.T. N(W) = NVAL
*
IF( ITMP1.LE.NVAL( JI ) ) THEN
AB( JI, 1 ) = TMP1
NAB( JI, 1 ) = ITMP1
END IF
IF( ITMP1.GE.NVAL( JI ) ) THEN
AB( JI, 2 ) = TMP1
NAB( JI, 2 ) = ITMP1
END IF
END IF
100 CONTINUE
KL = KLNEW
*
* END OF SERIAL VERSION OF THE LOOP
*
END IF
*
* CHECK FOR CONVERGENCE
*
KFNEW = KF
DO 110 JI = KF, KL
TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) )
TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) )
IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR.
$ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN
*
* CONVERGED -- SWAP WITH POSITION KFNEW,
* THEN INCREMENT KFNEW
*
IF( JI.GT.KFNEW ) THEN
TMP1 = AB( JI, 1 )
TMP2 = AB( JI, 2 )
ITMP1 = NAB( JI, 1 )
ITMP2 = NAB( JI, 2 )
AB( JI, 1 ) = AB( KFNEW, 1 )
AB( JI, 2 ) = AB( KFNEW, 2 )
NAB( JI, 1 ) = NAB( KFNEW, 1 )
NAB( JI, 2 ) = NAB( KFNEW, 2 )
AB( KFNEW, 1 ) = TMP1
AB( KFNEW, 2 ) = TMP2
NAB( KFNEW, 1 ) = ITMP1
NAB( KFNEW, 2 ) = ITMP2
IF( IJOB.EQ.3 ) THEN
ITMP1 = NVAL( JI )
NVAL( JI ) = NVAL( KFNEW )
NVAL( KFNEW ) = ITMP1
END IF
END IF
KFNEW = KFNEW + 1
END IF
110 CONTINUE
KF = KFNEW
*
* CHOOSE MIDPOINTS
*
DO 120 JI = KF, KL
C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
120 CONTINUE
*
* IF NO MORE INTERVALS TO REFINE, QUIT.
*
IF( KF.GT.KL )
$ GO TO 140
130 CONTINUE
*
* CONVERGED
*
140 CONTINUE
INFO = MAX( KL+1-KF, 0 )
MOUT = KL
*
RETURN
*
* END OF DLAEBZ
*
END
CUT HERE............
CAT > DSTEQR.F <<'CUT HERE............'
SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* PURPOSE
* =======
*
* DSTEQR COMPUTES ALL EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A
* SYMMETRIC TRIDIAGONAL MATRIX USING THE IMPLICIT QL OR QR METHOD.
* THE EIGENVECTORS OF A FULL OR BAND SYMMETRIC MATRIX CAN ALSO BE FOUND
* IF DSYTRD OR DSPTRD OR DSBTRD HAS BEEN USED TO REDUCE THIS MATRIX TO
* TRIDIAGONAL FORM.
*
* ARGUMENTS
* =========
*
* COMPZ (INPUT) CHARACTER*1
* = 'N': COMPUTE EIGENVALUES ONLY.
* = 'V': COMPUTE EIGENVALUES AND EIGENVECTORS OF THE ORIGINAL
* SYMMETRIC MATRIX. ON ENTRY, Z MUST CONTAIN THE
* ORTHOGONAL MATRIX USED TO REDUCE THE ORIGINAL MATRIX
* TO TRIDIAGONAL FORM.
* = 'I': COMPUTE EIGENVALUES AND EIGENVECTORS OF THE
* TRIDIAGONAL MATRIX. Z IS INITIALIZED TO THE IDENTITY
* MATRIX.
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX. N >= 0.
*
* D (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* ON ENTRY, THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
* ON EXIT, IF INFO = 0, THE EIGENVALUES IN ASCENDING ORDER.
*
* E (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* ON ENTRY, THE (N-1) SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
* MATRIX.
* ON EXIT, E HAS BEEN DESTROYED.
*
* Z (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDZ, N)
* ON ENTRY, IF COMPZ = 'V', THEN Z CONTAINS THE ORTHOGONAL
* MATRIX USED IN THE REDUCTION TO TRIDIAGONAL FORM.
* ON EXIT, IF COMPZ = 'V', Z CONTAINS THE ORTHONORMAL
* EIGENVECTORS OF THE ORIGINAL SYMMETRIC MATRIX, AND IF
* COMPZ = 'I', Z CONTAINS THE ORTHONORMAL EIGENVECTORS OF
* THE SYMMETRIC TRIDIAGONAL MATRIX. IF AN ERROR EXIT IS
* MADE, Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE
* STORED EIGENVALUES.
* IF COMPZ = 'N', THEN Z IS NOT REFERENCED.
*
* LDZ (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY Z. LDZ >= 1, AND IF
* EIGENVECTORS ARE DESIRED, THEN LDZ >= MAX(1,N).
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (MAX(1,2*N-2))
* IF COMPZ = 'N', THEN WORK IS NOT REFERENCED.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
* > 0: THE ALGORITHM HAS FAILED TO FIND ALL THE EIGENVALUES IN
* A TOTAL OF 30*N ITERATIONS; IF INFO = I, THEN I
* ELEMENTS OF E HAVE NOT CONVERGED TO ZERO; ON EXIT, D
* AND E CONTAIN THE ELEMENTS OF A SYMMETRIC TRIDIAGONAL
* MATRIX WHICH IS ORTHOGONALLY SIMILAR TO THE ORIGINAL
* MATRIX.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, ICOMPZ, II, J, JTOT, K, L, L1, LEND, LENDM1,
$ LENDP1, LM1, M, MM, MM1, NM1, NMAXIT
DOUBLE PRECISION B, C, EPS, F, G, P, R, RT1, RT2, S, TST
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL LSAME, DLAMCH, DLAPY2
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLAE2, DLAEV2, DLARTG, DLASR, DLAZRO, DSWAP,
$ XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, MAX, SIGN
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEQR', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.GT.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* DETERMINE THE UNIT ROUNDOFF FOR THIS ENVIRONMENT.
*
EPS = DLAMCH( 'E' )
*
* COMPUTE THE EIGENVALUES AND EIGENVECTORS OF THE TRIDIAGONAL
* MATRIX.
*
IF( ICOMPZ.EQ.2 )
$ CALL DLAZRO( N, N, ZERO, ONE, Z, LDZ )
*
NMAXIT = N*MAXIT
JTOT = 0
*
* DETERMINE WHERE THE MATRIX SPLITS AND CHOOSE QL OR QR ITERATION
* FOR EACH BLOCK, ACCORDING TO WHETHER TOP OR BOTTOM DIAGONAL
* ELEMENT IS SMALLER.
*
L1 = 1
NM1 = N - 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 160
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
IF( L1.LE.NM1 ) THEN
DO 20 M = L1, NM1
TST = ABS( E( M ) )
IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) )
$ GO TO 30
20 CONTINUE
END IF
M = N
*
30 CONTINUE
L = L1
LEND = M
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
L = LEND
LEND = L1
END IF
L1 = M + 1
*
IF( LEND.GE.L ) THEN
*
* QL ITERATION
*
* LOOK FOR SMALL SUBDIAGONAL ELEMENT.
*
40 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 50 M = L, LENDM1
TST = ABS( E( M ) )
IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) )
$ GO TO 60
50 CONTINUE
END IF
*
M = LEND
*
60 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 80
*
* IF REMAINING MATRIX IS 2-BY-2, USE DLAE2 OR DLAEV2
* TO COMPUTE ITS EIGENSYSTEM.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
WORK( L ) = C
WORK( N-1+L ) = S
CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
END IF
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 40
GO TO 10
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* FORM SHIFT.
*
G = ( D( L+1 )-P ) / ( TWO*E( L ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* INNER LOOP
*
MM1 = M - 1
DO 70 I = MM1, L, -1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M-1 )
$ E( I+1 ) = R
G = D( I+1 ) - P
R = ( D( I )-G )*S + TWO*C*B
P = S*R
D( I+1 ) = G + P
G = C*R - B
*
* IF EIGENVECTORS ARE DESIRED, THEN SAVE ROTATIONS.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = -S
END IF
*
70 CONTINUE
*
* IF EIGENVECTORS ARE DESIRED, THEN APPLY SAVED ROTATIONS.
*
IF( ICOMPZ.GT.0 ) THEN
MM = M - L + 1
CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
$ Z( 1, L ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( L ) = G
GO TO 40
*
* EIGENVALUE FOUND.
*
80 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 40
GO TO 10
*
ELSE
*
* QR ITERATION
*
* LOOK FOR SMALL SUPERDIAGONAL ELEMENT.
*
90 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 100 M = L, LENDP1, -1
TST = ABS( E( M-1 ) )
IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M-1 ) ) ) )
$ GO TO 110
100 CONTINUE
END IF
*
M = LEND
*
110 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 130
*
* IF REMAINING MATRIX IS 2-BY-2, USE DLAE2 OR DLAEV2
* TO COMPUTE ITS EIGENSYSTEM.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
WORK( M ) = C
WORK( N-1+M ) = S
CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
END IF
D( L-1 ) = RT1
D( L ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 90
GO TO 10
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* FORM SHIFT.
*
G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* INNER LOOP
*
LM1 = L - 1
DO 120 I = M, LM1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M )
$ E( I-1 ) = R
G = D( I ) - P
R = ( D( I+1 )-G )*S + TWO*C*B
P = S*R
D( I ) = G + P
G = C*R - B
*
* IF EIGENVECTORS ARE DESIRED, THEN SAVE ROTATIONS.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = S
END IF
*
120 CONTINUE
*
* IF EIGENVECTORS ARE DESIRED, THEN APPLY SAVED ROTATIONS.
*
IF( ICOMPZ.GT.0 ) THEN
MM = L - M + 1
CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
$ Z( 1, M ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( LM1 ) = G
GO TO 90
*
* EIGENVALUE FOUND.
*
130 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 90
GO TO 10
*
END IF
*
* SET ERROR -- NO CONVERGENCE TO AN EIGENVALUE AFTER A TOTAL
* OF N*MAXIT ITERATIONS.
*
140 CONTINUE
DO 150 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
150 CONTINUE
RETURN
*
* ORDER EIGENVALUES AND EIGENVECTORS.
*
160 CONTINUE
DO 180 II = 2, N
I = II - 1
K = I
P = D( I )
DO 170 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
170 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
IF( ICOMPZ.GT.0 )
$ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
*
RETURN
*
* END OF DSTEQR
*
END
CUT HERE............
CAT > DLARTG.F <<'CUT HERE............'
SUBROUTINE DLARTG( F, G, CS, SN, R )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
DOUBLE PRECISION CS, F, G, R, SN
* ..
*
* PURPOSE
* =======
*
* DLARTG GENERATE A PLANE ROTATION SO THAT
*
* [ CS SN ] . [ F ] = [ R ] WHERE CS**2 + SN**2 = 1.
* [ -SN CS ] [ G ] [ 0 ]
*
* THIS IS A FASTER VERSION OF THE BLAS1 ROUTINE DROTG, EXCEPT FOR
* THE FOLLOWING DIFFERENCES:
* F AND G ARE UNCHANGED ON RETURN.
* IF G=0, THEN CS=1 AND SN=0.
* IF F=0 AND (G .NE. 0), THEN CS=0 AND SN=1 WITHOUT DOING ANY
* FLOATING POINT OPERATIONS (SAVES WORK IN DBDSQR WHEN
* THERE ARE ZEROS ON THE DIAGONAL).
*
* ARGUMENTS
* =========
*
* F (INPUT) DOUBLE PRECISION
* THE FIRST COMPONENT OF VECTOR TO BE ROTATED.
*
* G (INPUT) DOUBLE PRECISION
* THE SECOND COMPONENT OF VECTOR TO BE ROTATED.
*
* CS (OUTPUT) DOUBLE PRECISION
* THE COSINE OF THE ROTATION.
*
* SN (OUTPUT) DOUBLE PRECISION
* THE SINE OF THE ROTATION.
*
* R (OUTPUT) DOUBLE PRECISION
* THE NONZERO COMPONENT OF THE ROTATED VECTOR.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. LOCAL SCALARS ..
DOUBLE PRECISION T, TT
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, SQRT
* ..
* .. EXECUTABLE STATEMENTS ..
*
IF( G.EQ.ZERO ) THEN
CS = ONE
SN = ZERO
R = F
ELSE IF( F.EQ.ZERO ) THEN
CS = ZERO
SN = ONE
R = G
ELSE
IF( ABS( F ).GT.ABS( G ) ) THEN
T = G / F
TT = SQRT( ONE+T*T )
CS = ONE / TT
SN = T*CS
R = F*TT
ELSE
T = F / G
TT = SQRT( ONE+T*T )
SN = ONE / TT
CS = T*SN
R = G*TT
END IF
END IF
RETURN
*
* END OF DLARTG
*
END
CUT HERE............
CAT > DLASR.F <<'CUT HERE............'
SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER DIRECT, PIVOT, SIDE
INTEGER LDA, M, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), C( * ), S( * )
* ..
*
* PURPOSE
* =======
*
* DLASR PERFORMS THE TRANSFORMATION
*
* A := P*A, WHEN SIDE = 'L' OR 'L' ( LEFT-HAND SIDE )
*
* A := A*P', WHEN SIDE = 'R' OR 'R' ( RIGHT-HAND SIDE )
*
* WHERE A IS AN M BY N REAL MATRIX AND P IS AN ORTHOGONAL MATRIX,
* CONSISTING OF A SEQUENCE OF PLANE ROTATIONS DETERMINED BY THE
* PARAMETERS PIVOT AND DIRECT AS FOLLOWS ( Z = M WHEN SIDE = 'L' OR 'L'
* AND Z = N WHEN SIDE = 'R' OR 'R' ):
*
* WHEN DIRECT = 'F' OR 'F' ( FORWARD SEQUENCE ) THEN
*
* P = P( Z - 1 )*...*P( 2 )*P( 1 ),
*
* AND WHEN DIRECT = 'B' OR 'B' ( BACKWARD SEQUENCE ) THEN
*
* P = P( 1 )*P( 2 )*...*P( Z - 1 ),
*
* WHERE P( K ) IS A PLANE ROTATION MATRIX FOR THE FOLLOWING PLANES:
*
* WHEN PIVOT = 'V' OR 'V' ( VARIABLE PIVOT ),
* THE PLANE ( K, K + 1 )
*
* WHEN PIVOT = 'T' OR 'T' ( TOP PIVOT ),
* THE PLANE ( 1, K + 1 )
*
* WHEN PIVOT = 'B' OR 'B' ( BOTTOM PIVOT ),
* THE PLANE ( K, Z )
*
* C( K ) AND S( K ) MUST CONTAIN THE COSINE AND SINE THAT DEFINE THE
* MATRIX P( K ). THE TWO BY TWO PLANE ROTATION PART OF THE MATRIX
* P( K ), R( K ), IS ASSUMED TO BE OF THE FORM
*
* R( K ) = ( C( K ) S( K ) ).
* ( -S( K ) C( K ) )
*
* THIS VERSION VECTORISES ACROSS ROWS OF THE ARRAY A WHEN SIDE = 'L'.
*
* ARGUMENTS
* =========
*
* SIDE (INPUT) CHARACTER*1
* SPECIFIES WHETHER THE PLANE ROTATION MATRIX P IS APPLIED TO
* A ON THE LEFT OR THE RIGHT.
* = 'L': LEFT, COMPUTE A := P*A
* = 'R': RIGHT, COMPUTE A:= A*P'
*
* DIRECT (INPUT) CHARACTER*1
* SPECIFIES WHETHER P IS A FORWARD OR BACKWARD SEQUENCE OF
* PLANE ROTATIONS.
* = 'F': FORWARD, P = P( Z - 1 )*...*P( 2 )*P( 1 )
* = 'B': BACKWARD, P = P( 1 )*P( 2 )*...*P( Z - 1 )
*
* PIVOT (INPUT) CHARACTER*1
* SPECIFIES THE PLANE FOR WHICH P(K) IS A PLANE ROTATION
* MATRIX.
* = 'V': VARIABLE PIVOT, THE PLANE (K,K+1)
* = 'T': TOP PIVOT, THE PLANE (1,K+1)
* = 'B': BOTTOM PIVOT, THE PLANE (K,Z)
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX A. IF M <= 1, AN IMMEDIATE
* RETURN IS EFFECTED.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX A. IF N <= 1, AN
* IMMEDIATE RETURN IS EFFECTED.
*
* C, S (INPUT) DOUBLE PRECISION ARRAYS, DIMENSION
* (M-1) IF SIDE = 'L'
* (N-1) IF SIDE = 'R'
* C(K) AND S(K) CONTAIN THE COSINE AND SINE THAT DEFINE THE
* MATRIX P(K). THE TWO BY TWO PLANE ROTATION PART OF THE
* MATRIX P(K), R(K), IS ASSUMED TO BE OF THE FORM
* R( K ) = ( C( K ) S( K ) ).
* ( -S( K ) C( K ) )
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* THE M BY N MATRIX A. ON EXIT, A IS OVERWRITTEN BY P*A IF
* SIDE = 'R' OR BY A*P' IF SIDE = 'L'.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,M).
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, INFO, J
DOUBLE PRECISION CTEMP, STEMP, TEMP
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS
*
INFO = 0
IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
INFO = 1
ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
$ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
INFO = 2
ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
$ THEN
INFO = 3
ELSE IF( M.LT.0 ) THEN
INFO = 4
ELSE IF( N.LT.0 ) THEN
INFO = 5
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = 9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASR ', INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
$ RETURN
IF( LSAME( SIDE, 'L' ) ) THEN
*
* FORM P * A
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 20 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 10 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
10 CONTINUE
END IF
20 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 40 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 30 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
30 CONTINUE
END IF
40 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 60 J = 2, M
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 50 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
50 CONTINUE
END IF
60 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 80 J = M, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 70 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
70 CONTINUE
END IF
80 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 100 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 90 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
90 CONTINUE
END IF
100 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 120 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 110 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
110 CONTINUE
END IF
120 CONTINUE
END IF
END IF
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* FORM A * P'
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 140 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 130 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
130 CONTINUE
END IF
140 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 160 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 150 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
150 CONTINUE
END IF
160 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 180 J = 2, N
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 170 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
170 CONTINUE
END IF
180 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 200 J = N, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 190 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
190 CONTINUE
END IF
200 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 220 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 210 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
210 CONTINUE
END IF
220 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 240 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 230 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
230 CONTINUE
END IF
240 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* END OF DLASR
*
END
CUT HERE............
CAT > DLAEV2.F <<'CUT HERE............'
SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1
* ..
*
* PURPOSE
* =======
*
* DLAEV2 COMPUTES THE EIGENDECOMPOSITION OF A 2-BY-2 SYMMETRIC MATRIX
* [ A B ]
* [ B C ].
* ON RETURN, RT1 IS THE EIGENVALUE OF LARGER ABSOLUTE VALUE, RT2 IS THE
* EIGENVALUE OF SMALLER ABSOLUTE VALUE, AND (CS1,SN1) IS THE UNIT RIGHT
* EIGENVECTOR FOR RT1, GIVING THE DECOMPOSITION
*
* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]
* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].
*
* ARGUMENTS
* =========
*
* A (INPUT) DOUBLE PRECISION
* THE (1,1) ENTRY OF THE 2-BY-2 MATRIX.
*
* B (INPUT) DOUBLE PRECISION
* THE (1,2) ENTRY AND THE CONJUGATE OF THE (2,1) ENTRY OF THE
* 2-BY-2 MATRIX.
*
* C (INPUT) DOUBLE PRECISION
* THE (2,2) ENTRY OF THE 2-BY-2 MATRIX.
*
* RT1 (OUTPUT) DOUBLE PRECISION
* THE EIGENVALUE OF LARGER ABSOLUTE VALUE.
*
* RT2 (OUTPUT) DOUBLE PRECISION
* THE EIGENVALUE OF SMALLER ABSOLUTE VALUE.
*
* CS1 (OUTPUT) DOUBLE PRECISION
* SN1 (OUTPUT) DOUBLE PRECISION
* THE VECTOR (CS1, SN1) IS A UNIT RIGHT EIGENVECTOR FOR RT1.
*
* FURTHER DETAILS
* ===============
*
* RT1 IS ACCURATE TO A FEW ULPS BARRING OVER/UNDERFLOW.
*
* RT2 MAY BE INACCURATE IF THERE IS MASSIVE CANCELLATION IN THE
* DETERMINANT A*C-B*B; HIGHER PRECISION OR CORRECTLY ROUNDED OR
* CORRECTLY TRUNCATED ARITHMETIC WOULD BE NEEDED TO COMPUTE RT2
* ACCURATELY IN ALL CASES.
*
* CS1 AND SN1 ARE ACCURATE TO A FEW ULPS BARRING OVER/UNDERFLOW.
*
* OVERFLOW IS POSSIBLE ONLY IF RT1 IS WITHIN A FACTOR OF 5 OF OVERFLOW.
* UNDERFLOW IS HARMLESS IF THE INPUT DATA IS 0 OR EXCEEDS
* UNDERFLOW_THRESHOLD / MACHEPS.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
* ..
* .. LOCAL SCALARS ..
INTEGER SGN1, SGN2
DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
$ TB, TN
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, SQRT
* ..
* .. EXECUTABLE STATEMENTS ..
*
* COMPUTE THE EIGENVALUES
*
SM = A + C
DF = A - C
ADF = ABS( DF )
TB = B + B
AB = ABS( TB )
IF( ABS( A ).GT.ABS( C ) ) THEN
ACMX = A
ACMN = C
ELSE
ACMX = C
ACMN = A
END IF
IF( ADF.GT.AB ) THEN
RT = ADF*SQRT( ONE+( AB / ADF )**2 )
ELSE IF( ADF.LT.AB ) THEN
RT = AB*SQRT( ONE+( ADF / AB )**2 )
ELSE
*
* INCLUDES CASE AB=ADF=0
*
RT = AB*SQRT( TWO )
END IF
IF( SM.LT.ZERO ) THEN
RT1 = HALF*( SM-RT )
SGN1 = -1
*
* ORDER OF EXECUTION IMPORTANT.
* TO GET FULLY ACCURATE SMALLER EIGENVALUE,
* NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE IF( SM.GT.ZERO ) THEN
RT1 = HALF*( SM+RT )
SGN1 = 1
*
* ORDER OF EXECUTION IMPORTANT.
* TO GET FULLY ACCURATE SMALLER EIGENVALUE,
* NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE
*
* INCLUDES CASE RT1 = RT2 = 0
*
RT1 = HALF*RT
RT2 = -HALF*RT
SGN1 = 1
END IF
*
* COMPUTE THE EIGENVECTOR
*
IF( DF.GE.ZERO ) THEN
CS = DF + RT
SGN2 = 1
ELSE
CS = DF - RT
SGN2 = -1
END IF
ACS = ABS( CS )
IF( ACS.GT.AB ) THEN
CT = -TB / CS
SN1 = ONE / SQRT( ONE+CT*CT )
CS1 = CT*SN1
ELSE
IF( AB.EQ.ZERO ) THEN
CS1 = ONE
SN1 = ZERO
ELSE
TN = -CS / TB
CS1 = ONE / SQRT( ONE+TN*TN )
SN1 = TN*CS1
END IF
END IF
IF( SGN1.EQ.SGN2 ) THEN
TN = CS1
CS1 = -SN1
SN1 = TN
END IF
RETURN
*
* END OF DLAEV2
*
END
CUT HERE............
CAT > DLAZRO.F <<'CUT HERE............'
SUBROUTINE DLAZRO( M, N, ALPHA, BETA, A, LDA )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
INTEGER LDA, M, N
DOUBLE PRECISION ALPHA, BETA
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* PURPOSE
* =======
*
* DLAZRO INITIALIZES A 2-D ARRAY A TO BETA ON THE DIAGONAL AND
* ALPHA ON THE OFFDIAGONALS.
*
* ARGUMENTS
* =========
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX A. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX A. N >= 0.
*
* ALPHA (INPUT) DOUBLE PRECISION
* THE CONSTANT TO WHICH THE OFFDIAGONAL ELEMENTS ARE TO BE SET.
*
* BETA (INPUT) DOUBLE PRECISION
* THE CONSTANT TO WHICH THE DIAGONAL ELEMENTS ARE TO BE SET.
*
* A (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON EXIT, THE LEADING M BY N SUBMATRIX OF A IS SET SUCH THAT
* A(I,J) = ALPHA, 1 <= I <= M, 1 <= J <= N, I <> J
* A(I,I) = BETA, 1 <= I <= MIN(M,N).
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,M).
*
* =====================================================================
*
* .. LOCAL SCALARS ..
INTEGER I, J
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MIN
* ..
* .. EXECUTABLE STATEMENTS ..
*
DO 20 J = 1, N
DO 10 I = 1, M
A( I, J ) = ALPHA
10 CONTINUE
20 CONTINUE
*
DO 30 I = 1, MIN( M, N )
A( I, I ) = BETA
30 CONTINUE
*
RETURN
*
* END OF DLAZRO
*
END
CUT HERE............
CAT > DORGTR.F <<'CUT HERE............'
SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK )
* ..
*
* PURPOSE
* =======
*
* DORGTR GENERATES A REAL ORTHOGONAL MATRIX Q WHICH IS DEFINED AS THE
* PRODUCT OF N-1 ELEMENTARY REFLECTORS OF ORDER N, AS RETURNED BY
* DSYTRD:
*
* IF UPLO = 'U', Q = H(N-1) . . . H(2) H(1),
*
* IF UPLO = 'L', Q = H(1) H(2) . . . H(N-1).
*
* ARGUMENTS
* =========
*
* UPLO (INPUT) CHARACTER*1
* = 'U': UPPER TRIANGLE OF A CONTAINS ELEMENTARY REFLECTORS
* FROM DSYTRD;
* = 'L': LOWER TRIANGLE OF A CONTAINS ELEMENTARY REFLECTORS
* FROM DSYTRD.
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX Q. N >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS,
* AS RETURNED BY DSYTRD.
* ON EXIT, THE N-BY-N ORTHOGONAL MATRIX Q.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N).
*
* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY
* REFLECTOR H(I), AS RETURNED BY DSYTRD.
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK)
* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK.
*
* LWORK (INPUT) INTEGER
* THE DIMENSION OF THE ARRAY WORK. LWORK >= MAX(1,N-1).
* FOR OPTIMUM PERFORMANCE LWORK >= (N-1)*NB, WHERE NB IS
* THE OPTIMAL BLOCKSIZE.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. LOCAL SCALARS ..
LOGICAL UPPER
INTEGER I, IINFO, J
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DORGQL, DORGQR, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT ARGUMENTS
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, N-1 ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGTR', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( UPPER ) THEN
*
* Q WAS DETERMINED BY A CALL TO DSYTRD WITH UPLO = 'U'
*
* SHIFT THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS ONE
* COLUMN TO THE LEFT, AND SET THE LAST ROW AND COLUMN OF Q TO
* THOSE OF THE UNIT MATRIX
*
DO 20 J = 1, N - 1
DO 10 I = 1, J - 1
A( I, J ) = A( I, J+1 )
10 CONTINUE
A( N, J ) = ZERO
20 CONTINUE
DO 30 I = 1, N - 1
A( I, N ) = ZERO
30 CONTINUE
A( N, N ) = ONE
*
* GENERATE Q(1:N-1,1:N-1)
*
CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* Q WAS DETERMINED BY A CALL TO DSYTRD WITH UPLO = 'L'.
*
* SHIFT THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS ONE
* COLUMN TO THE RIGHT, AND SET THE FIRST ROW AND COLUMN OF Q TO
* THOSE OF THE UNIT MATRIX
*
DO 50 J = N, 2, -1
A( 1, J ) = ZERO
DO 40 I = J + 1, N
A( I, J ) = A( I, J-1 )
40 CONTINUE
50 CONTINUE
A( 1, 1 ) = ONE
DO 60 I = 2, N
A( I, 1 ) = ZERO
60 CONTINUE
IF( N.GT.1 ) THEN
*
* GENERATE Q(2:N,2:N)
*
CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
RETURN
*
* END OF DORGTR
*
END
CUT HERE............
CAT > DORGQR.F <<'CUT HERE............'
SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK )
* ..
*
* PURPOSE
* =======
*
* DORGQR GENERATES AN M-BY-N REAL MATRIX Q WITH ORTHONORMAL COLUMNS,
* WHICH IS DEFINED AS THE FIRST N COLUMNS OF A PRODUCT OF K ELEMENTARY
* REFLECTORS OF ORDER M
*
* Q = H(1) H(2) . . . H(K)
*
* AS RETURNED BY DGEQRF.
*
* ARGUMENTS
* =========
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX Q. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX Q. M >= N >= 0.
*
* K (INPUT) INTEGER
* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES THE
* MATRIX Q. N >= K >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH
* DEFINES THE ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS
* RETURNED BY DGEQRF IN THE FIRST K COLUMNS OF ITS ARRAY
* ARGUMENT A.
* ON EXIT, THE M-BY-N MATRIX Q.
*
* LDA (INPUT) INTEGER
* THE FIRST DIMENSION OF THE ARRAY A. LDA >= MAX(1,M).
*
* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K)
* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY
* REFLECTOR H(I), AS RETURNED BY DGEQRF.
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK)
* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK.
*
* LWORK (INPUT) INTEGER
* THE DIMENSION OF THE ARRAY WORK. LWORK >= MAX(1,N).
* FOR OPTIMUM PERFORMANCE LWORK >= N*NB, WHERE NB IS THE
* OPTIMAL BLOCKSIZE.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAS AN ILLEGAL VALUE
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB,
$ NBMIN, NX
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX, MIN
* ..
* .. EXTERNAL FUNCTIONS ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT ARGUMENTS
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGQR', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( N.LE.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* DETERMINE THE BLOCK SIZE.
*
NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
NBMIN = 2
NX = 0
IWS = N
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* DETERMINE WHEN TO CROSS OVER FROM BLOCKED TO UNBLOCKED CODE.
*
NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* DETERMINE IF WORKSPACE IS LARGE ENOUGH FOR BLOCKED CODE.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* NOT ENOUGH WORKSPACE TO USE OPTIMAL NB: REDUCE NB AND
* DETERMINE THE MINIMUM VALUE OF NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* USE BLOCKED CODE AFTER THE LAST BLOCK.
* THE FIRST KK COLUMNS ARE HANDLED BY THE BLOCK METHOD.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
* SET A(1:KK,KK+1:N) TO ZERO.
*
DO 20 J = KK + 1, N
DO 10 I = 1, KK
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* USE UNBLOCKED CODE FOR THE LAST OR ONLY BLOCK.
*
IF( KK.LT.N )
$ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
$ TAU( KK+1 ), WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* USE BLOCKED CODE
*
DO 50 I = KI + 1, 1, -NB
IB = MIN( NB, K-I+1 )
IF( I+IB.LE.N ) THEN
*
* FORM THE TRIANGULAR FACTOR OF THE BLOCK REFLECTOR
* H = H(I) H(I+1) . . . H(I+IB-1)
*
CALL DLARFT( 'FORWARD', 'COLUMNWISE', M-I+1, IB,
$ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
*
* APPLY H TO A(I:M,I+IB:N) FROM THE LEFT
*
CALL DLARFB( 'LEFT', 'NO TRANSPOSE', 'FORWARD',
$ 'COLUMNWISE', M-I+1, N-I-IB+1, IB,
$ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
$ LDA, WORK( IB+1 ), LDWORK )
END IF
*
* APPLY H TO ROWS I:M OF CURRENT BLOCK
*
CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
* SET ROWS 1:I-1 OF CURRENT BLOCK TO ZERO
*
DO 40 J = I, I + IB - 1
DO 30 L = 1, I - 1
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* END OF DORGQR
*
END
CUT HERE............
CAT > DORG2R.F <<'CUT HERE............'
SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* FEBRUARY 29, 1992
*
* .. SCALAR ARGUMENTS ..
INTEGER INFO, K, LDA, M, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* PURPOSE
* =======
*
* DORG2R GENERATES AN M BY N REAL MATRIX Q WITH ORTHONORMAL COLUMNS,
* WHICH IS DEFINED AS THE FIRST N COLUMNS OF A PRODUCT OF K ELEMENTARY
* REFLECTORS OF ORDER M
*
* Q = H(1) H(2) . . . H(K)
*
* AS RETURNED BY DGEQRF.
*
* ARGUMENTS
* =========
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX Q. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX Q. M >= N >= 0.
*
* K (INPUT) INTEGER
* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES THE
* MATRIX Q. N >= K >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH
* DEFINES THE ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS
* RETURNED BY DGEQRF IN THE FIRST K COLUMNS OF ITS ARRAY
* ARGUMENT A.
* ON EXIT, THE M-BY-N MATRIX Q.
*
* LDA (INPUT) INTEGER
* THE FIRST DIMENSION OF THE ARRAY A. LDA >= MAX(1,M).
*
* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K)
* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY
* REFLECTOR H(I), AS RETURNED BY DGEQRF.
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (N)
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAS AN ILLEGAL VALUE
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, J, L
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLARF, DSCAL, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT ARGUMENTS
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORG2R', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( N.LE.0 )
$ RETURN
*
* INITIALISE COLUMNS K+1:N TO COLUMNS OF THE UNIT MATRIX
*
DO 20 J = K + 1, N
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( J, J ) = ONE
20 CONTINUE
*
DO 40 I = K, 1, -1
*
* APPLY H(I) TO A(I:M,I:N) FROM THE LEFT
*
IF( I.LT.N ) THEN
A( I, I ) = ONE
CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
$ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
A( I, I ) = ONE - TAU( I )
*
* SET A(1:I-1,I) TO ZERO
*
DO 30 L = 1, I - 1
A( L, I ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* END OF DORG2R
*
END
CUT HERE............
CAT > DORGQL.F <<'CUT HERE............'
SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK )
* ..
*
* PURPOSE
* =======
*
* DORGQL GENERATES AN M-BY-N REAL MATRIX Q WITH ORTHONORMAL COLUMNS,
* WHICH IS DEFINED AS THE LAST N COLUMNS OF A PRODUCT OF K ELEMENTARY
* REFLECTORS OF ORDER M
*
* Q = H(K) . . . H(2) H(1)
*
* AS RETURNED BY DGEQLF.
*
* ARGUMENTS
* =========
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX Q. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX Q. M >= N >= 0.
*
* K (INPUT) INTEGER
* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES THE
* MATRIX Q. N >= K >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE (N-K+I)-TH COLUMN MUST CONTAIN THE VECTOR WHICH
* DEFINES THE ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS
* RETURNED BY DGEQLF IN THE LAST K COLUMNS OF ITS ARRAY
* ARGUMENT A.
* ON EXIT, THE M-BY-N MATRIX Q.
*
* LDA (INPUT) INTEGER
* THE FIRST DIMENSION OF THE ARRAY A. LDA >= MAX(1,M).
*
* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K)
* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY
* REFLECTOR H(I), AS RETURNED BY DGEQLF.
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK)
* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK.
*
* LWORK (INPUT) INTEGER
* THE DIMENSION OF THE ARRAY WORK. LWORK >= MAX(1,N).
* FOR OPTIMUM PERFORMANCE LWORK >= N*NB, WHERE NB IS THE
* OPTIMAL BLOCKSIZE.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAS AN ILLEGAL VALUE
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, NB, NBMIN,
$ NX
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX, MIN
* ..
* .. EXTERNAL FUNCTIONS ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT ARGUMENTS
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGQL', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( N.LE.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* DETERMINE THE BLOCK SIZE.
*
NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 )
NBMIN = 2
NX = 0
IWS = N
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* DETERMINE WHEN TO CROSS OVER FROM BLOCKED TO UNBLOCKED CODE.
*
NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* DETERMINE IF WORKSPACE IS LARGE ENOUGH FOR BLOCKED CODE.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* NOT ENOUGH WORKSPACE TO USE OPTIMAL NB: REDUCE NB AND
* DETERMINE THE MINIMUM VALUE OF NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* USE BLOCKED CODE AFTER THE FIRST BLOCK.
* THE LAST KK COLUMNS ARE HANDLED BY THE BLOCK METHOD.
*
KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
*
* SET A(M-KK+1:M,1:N-KK) TO ZERO.
*
DO 20 J = 1, N - KK
DO 10 I = M - KK + 1, M
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* USE UNBLOCKED CODE FOR THE FIRST OR ONLY BLOCK.
*
CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* USE BLOCKED CODE
*
DO 50 I = K - KK + 1, K, NB
IB = MIN( NB, K-I+1 )
IF( N-K+I.GT.1 ) THEN
*
* FORM THE TRIANGULAR FACTOR OF THE BLOCK REFLECTOR
* H = H(I+IB-1) . . . H(I+1) H(I)
*
CALL DLARFT( 'BACKWARD', 'COLUMNWISE', M-K+I+IB-1, IB,
$ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
*
* APPLY H TO A(1:M-K+I+IB-1,1:N-K+I-1) FROM THE LEFT
*
CALL DLARFB( 'LEFT', 'NO TRANSPOSE', 'BACKWARD',
$ 'COLUMNWISE', M-K+I+IB-1, N-K+I-1, IB,
$ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
$ WORK( IB+1 ), LDWORK )
END IF
*
* APPLY H TO ROWS 1:M-K+I+IB-1 OF CURRENT BLOCK
*
CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
$ TAU( I ), WORK, IINFO )
*
* SET ROWS M-K+I+IB:M OF CURRENT BLOCK TO ZERO
*
DO 40 J = N - K + I, N - K + I + IB - 1
DO 30 L = M - K + I + IB, M
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* END OF DORGQL
*
END
CUT HERE............
CAT > DLARFB.F <<'CUT HERE............'
SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* FEBRUARY 29, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* PURPOSE
* =======
*
* DLARFB APPLIES A REAL BLOCK REFLECTOR H OR ITS TRANSPOSE H' TO A
* REAL M BY N MATRIX C, FROM EITHER THE LEFT OR THE RIGHT.
*
* ARGUMENTS
* =========
*
* SIDE (INPUT) CHARACTER*1
* = 'L': APPLY H OR H' FROM THE LEFT
* = 'R': APPLY H OR H' FROM THE RIGHT
*
* TRANS (INPUT) CHARACTER*1
* = 'N': APPLY H (NO TRANSPOSE)
* = 'T': APPLY H' (TRANSPOSE)
*
* DIRECT (INPUT) CHARACTER*1
* INDICATES HOW H IS FORMED FROM A PRODUCT OF ELEMENTARY
* REFLECTORS
* = 'F': H = H(1) H(2) . . . H(K) (FORWARD)
* = 'B': H = H(K) . . . H(2) H(1) (BACKWARD)
*
* STOREV (INPUT) CHARACTER*1
* INDICATES HOW THE VECTORS WHICH DEFINE THE ELEMENTARY
* REFLECTORS ARE STORED:
* = 'C': COLUMNWISE
* = 'R': ROWWISE
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX C.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX C.
*
* K (INPUT) INTEGER
* THE ORDER OF THE MATRIX T (= THE NUMBER OF ELEMENTARY
* REFLECTORS WHOSE PRODUCT DEFINES THE BLOCK REFLECTOR).
*
* V (INPUT) DOUBLE PRECISION ARRAY, DIMENSION
* (LDV,K) IF STOREV = 'C'
* (LDV,M) IF STOREV = 'R' AND SIDE = 'L'
* (LDV,N) IF STOREV = 'R' AND SIDE = 'R'
* THE MATRIX V. SEE FURTHER DETAILS.
*
* LDV (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY V.
* IF STOREV = 'C' AND SIDE = 'L', LDV >= MAX(1,M);
* IF STOREV = 'C' AND SIDE = 'R', LDV >= MAX(1,N);
* IF STOREV = 'R', LDV >= K.
*
* T (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDT,K)
* THE TRIANGULAR K BY K MATRIX T IN THE REPRESENTATION OF THE
* BLOCK REFLECTOR.
*
* LDT (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY T. LDT >= K.
*
* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N)
* ON ENTRY, THE M BY N MATRIX C.
* ON EXIT, C IS OVERWRITTEN BY H*C OR H'*C OR C*H OR C*H'.
*
* LDC (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY C. LDA >= MAX(1,M).
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LDWORK,K)
*
* LDWORK (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY WORK.
* IF SIDE = 'L', LDWORK >= MAX(1,N);
* IF SIDE = 'R', LDWORK >= MAX(1,M).
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. LOCAL SCALARS ..
CHARACTER TRANST
INTEGER I, J
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DCOPY, DGEMM, DTRMM
* ..
* .. EXECUTABLE STATEMENTS ..
*
* QUICK RETURN IF POSSIBLE
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( LSAME( TRANS, 'N' ) ) THEN
TRANST = 'T'
ELSE
TRANST = 'N'
END IF
*
IF( LSAME( STOREV, 'C' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* LET V = ( V1 ) (FIRST K ROWS)
* ( V2 )
* WHERE V1 IS UNIT LOWER TRIANGULAR.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* FORM H * C OR H' * C WHERE C = ( C1 )
* ( C2 )
*
* W := C' * V = (C1'*V1 + C2'*V2) (STORED IN WORK)
*
* W := C1'
*
DO 10 J = 1, K
CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL DTRMM( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', N,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2'*V2
*
CALL DGEMM( 'TRANSPOSE', 'NO TRANSPOSE', N, K, M-K,
$ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T' OR W * T
*
CALL DTRMM( 'RIGHT', 'UPPER', TRANST, 'NON-UNIT', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W'
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2 * W'
*
CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M-K, N, K,
$ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
$ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1'
*
CALL DTRMM( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', N, K,
$ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W'
*
DO 30 J = 1, K
DO 20 I = 1, N
C( J, I ) = C( J, I ) - WORK( I, J )
20 CONTINUE
30 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* FORM C * H OR C * H' WHERE C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (STORED IN WORK)
*
* W := C1
*
DO 40 J = 1, K
CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL DTRMM( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', M,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', M, K, N-K,
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T OR W * T'
*
CALL DTRMM( 'RIGHT', 'UPPER', TRANS, 'NON-UNIT', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V'
*
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2'
*
CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M, N-K, K,
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
$ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1'
*
CALL DTRMM( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', M, K,
$ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
ELSE
*
* LET V = ( V1 )
* ( V2 ) (LAST K ROWS)
* WHERE V2 IS UNIT UPPER TRIANGULAR.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* FORM H * C OR H' * C WHERE C = ( C1 )
* ( C2 )
*
* W := C' * V = (C1'*V1 + C2'*V2) (STORED IN WORK)
*
* W := C2'
*
DO 70 J = 1, K
CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL DTRMM( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', N,
$ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1'*V1
*
CALL DGEMM( 'TRANSPOSE', 'NO TRANSPOSE', N, K, M-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T' OR W * T
*
CALL DTRMM( 'RIGHT', 'LOWER', TRANST, 'NON-UNIT', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W'
*
IF( M.GT.K ) THEN
*
* C1 := C1 - V1 * W'
*
CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M-K, N, K,
$ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2'
*
CALL DTRMM( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', N, K,
$ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W'
*
DO 90 J = 1, K
DO 80 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
80 CONTINUE
90 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* FORM C * H OR C * H' WHERE C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (STORED IN WORK)
*
* W := C2
*
DO 100 J = 1, K
CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL DTRMM( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', M,
$ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T OR W * T'
*
CALL DTRMM( 'RIGHT', 'LOWER', TRANS, 'NON-UNIT', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V'
*
IF( N.GT.K ) THEN
*
* C1 := C1 - W * V1'
*
CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2'
*
CALL DTRMM( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', M, K,
$ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
110 CONTINUE
120 CONTINUE
END IF
END IF
*
ELSE IF( LSAME( STOREV, 'R' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* LET V = ( V1 V2 ) (V1: FIRST K COLUMNS)
* WHERE V1 IS UNIT UPPER TRIANGULAR.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* FORM H * C OR H' * C WHERE C = ( C1 )
* ( C2 )
*
* W := C' * V' = (C1'*V1' + C2'*V2') (STORED IN WORK)
*
* W := C1'
*
DO 130 J = 1, K
CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1'
*
CALL DTRMM( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', N, K,
$ ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2'*V2'
*
CALL DGEMM( 'TRANSPOSE', 'TRANSPOSE', N, K, M-K, ONE,
$ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
$ WORK, LDWORK )
END IF
*
* W := W * T' OR W * T
*
CALL DTRMM( 'RIGHT', 'UPPER', TRANST, 'NON-UNIT', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V' * W'
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2' * W'
*
CALL DGEMM( 'TRANSPOSE', 'TRANSPOSE', M-K, N, K, -ONE,
$ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
$ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
CALL DTRMM( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', N,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W'
*
DO 150 J = 1, K
DO 140 I = 1, N
C( J, I ) = C( J, I ) - WORK( I, J )
140 CONTINUE
150 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* FORM C * H OR C * H' WHERE C = ( C1 C2 )
*
* W := C * V' = (C1*V1' + C2*V2') (STORED IN WORK)
*
* W := C1
*
DO 160 J = 1, K
CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1'
*
CALL DTRMM( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', M, K,
$ ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2'
*
CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M, K, N-K,
$ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T OR W * T'
*
CALL DTRMM( 'RIGHT', 'UPPER', TRANS, 'NON-UNIT', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2
*
CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', M, N-K, K,
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
$ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
CALL DTRMM( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', M,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
*
END IF
*
ELSE
*
* LET V = ( V1 V2 ) (V2: LAST K COLUMNS)
* WHERE V2 IS UNIT LOWER TRIANGULAR.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* FORM H * C OR H' * C WHERE C = ( C1 )
* ( C2 )
*
* W := C' * V' = (C1'*V1' + C2'*V2') (STORED IN WORK)
*
* W := C2'
*
DO 190 J = 1, K
CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2'
*
CALL DTRMM( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', N, K,
$ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1'*V1'
*
CALL DGEMM( 'TRANSPOSE', 'TRANSPOSE', N, K, M-K, ONE,
$ C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T' OR W * T
*
CALL DTRMM( 'RIGHT', 'LOWER', TRANST, 'NON-UNIT', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V' * W'
*
IF( M.GT.K ) THEN
*
* C1 := C1 - V1' * W'
*
CALL DGEMM( 'TRANSPOSE', 'TRANSPOSE', M-K, N, K, -ONE,
$ V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL DTRMM( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', N,
$ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W'
*
DO 210 J = 1, K
DO 200 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
200 CONTINUE
210 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* FORM C * H OR C * H' WHERE C = ( C1 C2 )
*
* W := C * V' = (C1*V1' + C2*V2') (STORED IN WORK)
*
* W := C2
*
DO 220 J = 1, K
CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2'
*
CALL DTRMM( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', M, K,
$ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1'
*
CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T OR W * T'
*
CALL DTRMM( 'RIGHT', 'LOWER', TRANS, 'NON-UNIT', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( N.GT.K ) THEN
*
* C1 := C1 - W * V1
*
CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL DTRMM( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', M,
$ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
230 CONTINUE
240 CONTINUE
*
END IF
*
END IF
END IF
*
RETURN
*
* END OF DLARFB
*
END
CUT HERE............
CAT > DLARFT.F <<'CUT HERE............'
SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* FEBRUARY 29, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER DIRECT, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* PURPOSE
* =======
*
* DLARFT FORMS THE TRIANGULAR FACTOR T OF A REAL BLOCK REFLECTOR H
* OF ORDER N, WHICH IS DEFINED AS A PRODUCT OF K ELEMENTARY REFLECTORS.
*
* IF DIRECT = 'F', H = H(1) H(2) . . . H(K) AND T IS UPPER TRIANGULAR;
*
* IF DIRECT = 'B', H = H(K) . . . H(2) H(1) AND T IS LOWER TRIANGULAR.
*
* IF STOREV = 'C', THE VECTOR WHICH DEFINES THE ELEMENTARY REFLECTOR
* H(I) IS STORED IN THE I-TH COLUMN OF THE ARRAY V, AND
*
* H = I - V * T * V'
*
* IF STOREV = 'R', THE VECTOR WHICH DEFINES THE ELEMENTARY REFLECTOR
* H(I) IS STORED IN THE I-TH ROW OF THE ARRAY V, AND
*
* H = I - V' * T * V
*
* ARGUMENTS
* =========
*
* DIRECT (INPUT) CHARACTER*1
* SPECIFIES THE ORDER IN WHICH THE ELEMENTARY REFLECTORS ARE
* MULTIPLIED TO FORM THE BLOCK REFLECTOR:
* = 'F': H = H(1) H(2) . . . H(K) (FORWARD)
* = 'B': H = H(K) . . . H(2) H(1) (BACKWARD)
*
* STOREV (INPUT) CHARACTER*1
* SPECIFIES HOW THE VECTORS WHICH DEFINE THE ELEMENTARY
* REFLECTORS ARE STORED (SEE ALSO FURTHER DETAILS):
* = 'C': COLUMNWISE
* = 'R': ROWWISE
*
* N (INPUT) INTEGER
* THE ORDER OF THE BLOCK REFLECTOR H. N >= 0.
*
* K (INPUT) INTEGER
* THE ORDER OF THE TRIANGULAR FACTOR T (= THE NUMBER OF
* ELEMENTARY REFLECTORS). K >= 1.
*
* V (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION
* (LDV,K) IF STOREV = 'C'
* (LDV,N) IF STOREV = 'R'
* THE MATRIX V. SEE FURTHER DETAILS.
*
* LDV (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY V.
* IF STOREV = 'C', LDV >= MAX(1,N); IF STOREV = 'R', LDV >= K.
*
* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K)
* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY
* REFLECTOR H(I).
*
* T (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDT,K)
* THE K BY K TRIANGULAR FACTOR T OF THE BLOCK REFLECTOR.
* IF DIRECT = 'F', T IS UPPER TRIANGULAR; IF DIRECT = 'B', T IS
* LOWER TRIANGULAR. THE REST OF THE ARRAY IS NOT USED.
*
* LDT (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY T. LDT >= K.
*
* FURTHER DETAILS
* ===============
*
* THE SHAPE OF THE MATRIX V AND THE STORAGE OF THE VECTORS WHICH DEFINE
* THE H(I) IS BEST ILLUSTRATED BY THE FOLLOWING EXAMPLE WITH N = 5 AND
* K = 3. THE ELEMENTS EQUAL TO 1 ARE NOT STORED; THE CORRESPONDING
* ARRAY ELEMENTS ARE MODIFIED BUT RESTORED ON EXIT. THE REST OF THE
* ARRAY IS NOT USED.
*
* DIRECT = 'F' AND STOREV = 'C': DIRECT = 'F' AND STOREV = 'R':
*
* V = ( 1 ) V = ( 1 V1 V1 V1 V1 )
* ( V1 1 ) ( 1 V2 V2 V2 )
* ( V1 V2 1 ) ( 1 V3 V3 )
* ( V1 V2 V3 )
* ( V1 V2 V3 )
*
* DIRECT = 'B' AND STOREV = 'C': DIRECT = 'B' AND STOREV = 'R':
*
* V = ( V1 V2 V3 ) V = ( V1 V1 1 )
* ( V1 V2 V3 ) ( V2 V2 V2 1 )
* ( 1 V2 V3 ) ( V3 V3 V3 V3 1 )
* ( 1 V3 )
* ( 1 )
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, J
DOUBLE PRECISION VII
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DGEMV, DTRMV
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. EXECUTABLE STATEMENTS ..
*
* QUICK RETURN IF POSSIBLE
*
IF( N.EQ.0 )
$ RETURN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 20 I = 1, K
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(I) = I
*
DO 10 J = 1, I
T( J, I ) = ZERO
10 CONTINUE
ELSE
*
* GENERAL CASE
*
VII = V( I, I )
V( I, I ) = ONE
IF( LSAME( STOREV, 'C' ) ) THEN
*
* T(1:I-1,I) := - TAU(I) * V(I:N,1:I-1)' * V(I:N,I)
*
CALL DGEMV( 'TRANSPOSE', N-I+1, I-1, -TAU( I ),
$ V( I, 1 ), LDV, V( I, I ), 1, ZERO,
$ T( 1, I ), 1 )
ELSE
*
* T(1:I-1,I) := - TAU(I) * V(1:I-1,I:N) * V(I,I:N)'
*
CALL DGEMV( 'NO TRANSPOSE', I-1, N-I+1, -TAU( I ),
$ V( 1, I ), LDV, V( I, I ), LDV, ZERO,
$ T( 1, I ), 1 )
END IF
V( I, I ) = VII
*
* T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I)
*
CALL DTRMV( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', I-1, T,
$ LDT, T( 1, I ), 1 )
T( I, I ) = TAU( I )
END IF
20 CONTINUE
ELSE
DO 40 I = K, 1, -1
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(I) = I
*
DO 30 J = I, K
T( J, I ) = ZERO
30 CONTINUE
ELSE
*
* GENERAL CASE
*
IF( I.LT.K ) THEN
IF( LSAME( STOREV, 'C' ) ) THEN
VII = V( N-K+I, I )
V( N-K+I, I ) = ONE
*
* T(I+1:K,I) :=
* - TAU(I) * V(1:N-K+I,I+1:K)' * V(1:N-K+I,I)
*
CALL DGEMV( 'TRANSPOSE', N-K+I, K-I, -TAU( I ),
$ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO,
$ T( I+1, I ), 1 )
V( N-K+I, I ) = VII
ELSE
VII = V( I, N-K+I )
V( I, N-K+I ) = ONE
*
* T(I+1:K,I) :=
* - TAU(I) * V(I+1:K,1:N-K+I) * V(I,1:N-K+I)'
*
CALL DGEMV( 'NO TRANSPOSE', K-I, N-K+I, -TAU( I ),
$ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
$ T( I+1, I ), 1 )
V( I, N-K+I ) = VII
END IF
*
* T(I+1:K,I) := T(I+1:K,I+1:K) * T(I+1:K,I)
*
CALL DTRMV( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', K-I,
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
END IF
T( I, I ) = TAU( I )
END IF
40 CONTINUE
END IF
RETURN
*
* END OF DLARFT
*
END
CUT HERE............
CAT > DORG2L.F <<'CUT HERE............'
SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* FEBRUARY 29, 1992
*
* .. SCALAR ARGUMENTS ..
INTEGER INFO, K, LDA, M, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* PURPOSE
* =======
*
* DORG2L GENERATES AN M BY N REAL MATRIX Q WITH ORTHONORMAL COLUMNS,
* WHICH IS DEFINED AS THE LAST N COLUMNS OF A PRODUCT OF K ELEMENTARY
* REFLECTORS OF ORDER M
*
* Q = H(K) . . . H(2) H(1)
*
* AS RETURNED BY DGEQLF.
*
* ARGUMENTS
* =========
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX Q. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX Q. M >= N >= 0.
*
* K (INPUT) INTEGER
* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES THE
* MATRIX Q. N >= K >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE (N-K+I)-TH COLUMN MUST CONTAIN THE VECTOR WHICH
* DEFINES THE ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS
* RETURNED BY DGEQLF IN THE LAST K COLUMNS OF ITS ARRAY
* ARGUMENT A.
* ON EXIT, THE M BY N MATRIX Q.
*
* LDA (INPUT) INTEGER
* THE FIRST DIMENSION OF THE ARRAY A. LDA >= MAX(1,M).
*
* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K)
* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY
* REFLECTOR H(I), AS RETURNED BY DGEQLF.
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (N)
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAS AN ILLEGAL VALUE
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, II, J, L
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLARF, DSCAL, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT ARGUMENTS
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORG2L', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( N.LE.0 )
$ RETURN
*
* INITIALISE COLUMNS 1:N-K TO COLUMNS OF THE UNIT MATRIX
*
DO 20 J = 1, N - K
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( M-N+J, J ) = ONE
20 CONTINUE
*
DO 40 I = 1, K
II = N - K + I
*
* APPLY H(I) TO A(1:M-K+I,1:N-K+I) FROM THE LEFT
*
A( M-N+II, II ) = ONE
CALL DLARF( 'LEFT', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
$ LDA, WORK )
CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
A( M-N+II, II ) = ONE - TAU( I )
*
* SET A(M-K+I+1:M,N-K+I) TO ZERO
*
DO 30 L = M - N + II + 1, M
A( L, II ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* END OF DORG2L
*
END
CUT HERE............
CAT > DLARF.F <<'CUT HERE............'
SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* FEBRUARY 29, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER SIDE
INTEGER INCV, LDC, M, N
DOUBLE PRECISION TAU
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
* PURPOSE
* =======
*
* DLARF APPLIES A REAL ELEMENTARY REFLECTOR H TO A REAL M BY N MATRIX
* C, FROM EITHER THE LEFT OR THE RIGHT. H IS REPRESENTED IN THE FORM
*
* H = I - TAU * V * V'
*
* WHERE TAU IS A REAL SCALAR AND V IS A REAL VECTOR.
*
* IF TAU = 0, THEN H IS TAKEN TO BE THE UNIT MATRIX.
*
* ARGUMENTS
* =========
*
* SIDE (INPUT) CHARACTER*1
* = 'L': FORM H * C
* = 'R': FORM C * H
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX C.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX C.
*
* V (INPUT) DOUBLE PRECISION ARRAY, DIMENSION
* (1 + (M-1)*ABS(INCV)) IF SIDE = 'L'
* OR (1 + (N-1)*ABS(INCV)) IF SIDE = 'R'
* THE VECTOR V IN THE REPRESENTATION OF H. V IS NOT USED IF
* TAU = 0.
*
* INCV (INPUT) INTEGER
* THE INCREMENT BETWEEN ELEMENTS OF V. INCV <> 0.
*
* TAU (INPUT) DOUBLE PRECISION
* THE VALUE TAU IN THE REPRESENTATION OF H.
*
* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N)
* ON ENTRY, THE M BY N MATRIX C.
* ON EXIT, C IS OVERWRITTEN BY THE MATRIX H * C IF SIDE = 'L',
* OR C * H IF SIDE = 'R'.
*
* LDC (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M).
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION
* (N) IF SIDE = 'L'
* OR (M) IF SIDE = 'R'
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DGEMV, DGER
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. EXECUTABLE STATEMENTS ..
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* FORM H * C
*
IF( TAU.NE.ZERO ) THEN
*
* W := C' * V
*
CALL DGEMV( 'TRANSPOSE', M, N, ONE, C, LDC, V, INCV, ZERO,
$ WORK, 1 )
*
* C := C - V * W'
*
CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* FORM C * H
*
IF( TAU.NE.ZERO ) THEN
*
* W := C * V
*
CALL DGEMV( 'NO TRANSPOSE', M, N, ONE, C, LDC, V, INCV,
$ ZERO, WORK, 1 )
*
* C := C - W * V'
*
CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* END OF DLARF
*
END
CUT HERE............
CAT > DLACPY.F <<'CUT HERE............'
SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* FEBRUARY 29, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER UPLO
INTEGER LDA, LDB, M, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* PURPOSE
* =======
*
* DLACPY COPIES ALL OR PART OF A TWO-DIMENSIONAL MATRIX A TO ANOTHER
* MATRIX B.
*
* ARGUMENTS
* =========
*
* UPLO (INPUT) CHARACTER*1
* SPECIFIES THE PART OF THE MATRIX A TO BE COPIED TO B.
* = 'U': UPPER TRIANGULAR PART
* = 'L': LOWER TRIANGULAR PART
* OTHERWISE: ALL OF THE MATRIX A
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX A. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX A. N >= 0.
*
* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* THE M BY N MATRIX A. IF UPLO = 'U', ONLY THE UPPER TRIANGLE
* OR TRAPEZOID IS ACCESSED; IF UPLO = 'L', ONLY THE LOWER
* TRIANGLE OR TRAPEZOID IS ACCESSED.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,M).
*
* B (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDB,N)
* ON EXIT, B = A IN THE LOCATIONS SPECIFIED BY UPLO.
*
* LDB (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY B. LDB >= MAX(1,M).
*
* =====================================================================
*
* .. LOCAL SCALARS ..
INTEGER I, J
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MIN
* ..
* .. EXECUTABLE STATEMENTS ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, MIN( J, M )
B( I, J ) = A( I, J )
10 CONTINUE
20 CONTINUE
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
DO 40 J = 1, N
DO 30 I = J, M
B( I, J ) = A( I, J )
30 CONTINUE
40 CONTINUE
ELSE
DO 60 J = 1, N
DO 50 I = 1, M
B( I, J ) = A( I, J )
50 CONTINUE
60 CONTINUE
END IF
RETURN
*
* END OF DLACPY
*
END
CUT HERE............
CAT > DSTERF.F <<'CUT HERE............'
SUBROUTINE DSTERF( N, D, E, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
INTEGER INFO, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
* PURPOSE
* =======
*
* DSTERF COMPUTES ALL EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX
* USING THE PAL-WALKER-KAHAN VARIANT OF THE QL OR QR ALGORITHM.
*
* ARGUMENTS
* =========
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX. N >= 0.
*
* D (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* ON ENTRY, THE N DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
* ON EXIT, IF INFO = 0, THE EIGENVALUES IN ASCENDING ORDER.
*
* E (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* ON ENTRY, THE (N-1) SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
* MATRIX.
* ON EXIT, E HAS BEEN DESTROYED.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
* > 0: THE ALGORITHM FAILED TO FIND ALL OF THE EIGENVALUES IN
* A TOTAL OF 30*N ITERATIONS; IF INFO = I, THEN I
* ELEMENTS OF E HAVE NOT CONVERGED TO ZERO.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, II, J, JTOT, K, L, L1, LEND, LENDM1, LENDP1,
$ LM1, M, MM1, NM1, NMAXIT
DOUBLE PRECISION ALPHA, BB, C, EPS, GAMMA, OLDC, OLDGAM, P, R,
$ RT1, RT2, RTE, S, SIGMA, TST
* ..
* .. EXTERNAL FUNCTIONS ..
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL DLAMCH, DLAPY2
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLAE2, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS.
*
INFO = 0
*
* QUICK RETURN IF POSSIBLE
*
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DSTERF', -INFO )
RETURN
END IF
IF( N.LE.1 )
$ RETURN
*
* DETERMINE THE UNIT ROUNDOFF FOR THIS ENVIRONMENT.
*
EPS = DLAMCH( 'E' )
*
* COMPUTE THE EIGENVALUES OF THE TRIDIAGONAL MATRIX.
*
DO 10 I = 1, N - 1
E( I ) = E( I )**2
10 CONTINUE
*
NMAXIT = N*MAXIT
SIGMA = ZERO
JTOT = 0
*
* DETERMINE WHERE THE MATRIX SPLITS AND CHOOSE QL OR QR ITERATION
* FOR EACH BLOCK, ACCORDING TO WHETHER TOP OR BOTTOM DIAGONAL
* ELEMENT IS SMALLER.
*
L1 = 1
NM1 = N - 1
*
20 CONTINUE
IF( L1.GT.N )
$ GO TO 170
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
IF( L1.LE.NM1 ) THEN
DO 30 M = L1, NM1
TST = SQRT( ABS( E( M ) ) )
IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) )
$ GO TO 40
30 CONTINUE
END IF
M = N
*
40 CONTINUE
L = L1
LEND = M
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
L = LEND
LEND = L1
END IF
L1 = M + 1
*
IF( LEND.GE.L ) THEN
*
* QL ITERATION
*
* LOOK FOR SMALL SUBDIAGONAL ELEMENT.
*
50 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 60 M = L, LENDM1
TST = SQRT( ABS( E( M ) ) )
IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) )
$ GO TO 70
60 CONTINUE
END IF
*
M = LEND
*
70 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 90
*
* IF REMAINING MATRIX IS 2 BY 2, USE DLAE2 TO COMPUTE ITS
* EIGENVALUES.
*
IF( M.EQ.L+1 ) THEN
RTE = SQRT( E( L ) )
CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 50
GO TO 20
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* FORM SHIFT.
*
RTE = SQRT( E( L ) )
SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
R = DLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* INNER LOOP
*
MM1 = M - 1
DO 80 I = MM1, L, -1
BB = E( I )
R = P + BB
IF( I.NE.M-1 )
$ E( I+1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
80 CONTINUE
*
E( L ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 50
*
* EIGENVALUE FOUND.
*
90 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 50
GO TO 20
*
ELSE
*
* QR ITERATION
*
* LOOK FOR SMALL SUPERDIAGONAL ELEMENT.
*
100 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 110 M = L, LENDP1, -1
TST = SQRT( ABS( E( M-1 ) ) )
IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M-1 ) ) ) )
$ GO TO 120
110 CONTINUE
END IF
*
M = LEND
*
120 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 140
*
* IF REMAINING MATRIX IS 2 BY 2, USE DLAE2 TO COMPUTE ITS
* EIGENVALUES.
*
IF( M.EQ.L-1 ) THEN
RTE = SQRT( E( L-1 ) )
CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )
D( L ) = RT1
D( L-1 ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 100
GO TO 20
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* FORM SHIFT.
*
RTE = SQRT( E( L-1 ) )
SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
R = DLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* INNER LOOP
*
LM1 = L - 1
DO 130 I = M, LM1
BB = E( I )
R = P + BB
IF( I.NE.M )
$ E( I-1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I+1 )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
130 CONTINUE
*
E( LM1 ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 100
*
* EIGENVALUE FOUND.
*
140 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 100
GO TO 20
*
END IF
*
* SET ERROR -- NO CONVERGENCE TO AN EIGENVALUE AFTER A TOTAL
* OF N*MAXIT ITERATIONS.
*
150 CONTINUE
DO 160 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
160 CONTINUE
RETURN
*
* SORT EIGENVALUES IN INCREASING ORDER.
*
170 CONTINUE
DO 190 II = 2, N
I = II - 1
K = I
P = D( I )
DO 180 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
180 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
END IF
190 CONTINUE
*
RETURN
*
* END OF DSTERF
*
END
CUT HERE............
CAT > DLAE2.F <<'CUT HERE............'
SUBROUTINE DLAE2( A, B, C, RT1, RT2 )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
DOUBLE PRECISION A, B, C, RT1, RT2
* ..
*
* PURPOSE
* =======
*
* DLAE2 COMPUTES THE EIGENVALUES OF A 2-BY-2 SYMMETRIC MATRIX
* [ A B ]
* [ B C ].
* ON RETURN, RT1 IS THE EIGENVALUE OF LARGER ABSOLUTE VALUE, AND RT2
* IS THE EIGENVALUE OF SMALLER ABSOLUTE VALUE.
*
* ARGUMENTS
* =========
*
* A (INPUT) DOUBLE PRECISION
* THE (1,1) ENTRY OF THE 2-BY-2 MATRIX.
*
* B (INPUT) DOUBLE PRECISION
* THE (1,2) AND (2,1) ENTRIES OF THE 2-BY-2 MATRIX.
*
* C (INPUT) DOUBLE PRECISION
* THE (2,2) ENTRY OF THE 2-BY-2 MATRIX.
*
* RT1 (OUTPUT) DOUBLE PRECISION
* THE EIGENVALUE OF LARGER ABSOLUTE VALUE.
*
* RT2 (OUTPUT) DOUBLE PRECISION
* THE EIGENVALUE OF SMALLER ABSOLUTE VALUE.
*
* FURTHER DETAILS
* ===============
*
* RT1 IS ACCURATE TO A FEW ULPS BARRING OVER/UNDERFLOW.
*
* RT2 MAY BE INACCURATE IF THERE IS MASSIVE CANCELLATION IN THE
* DETERMINANT A*C-B*B; HIGHER PRECISION OR CORRECTLY ROUNDED OR
* CORRECTLY TRUNCATED ARITHMETIC WOULD BE NEEDED TO COMPUTE RT2
* ACCURATELY IN ALL CASES.
*
* OVERFLOW IS POSSIBLE ONLY IF RT1 IS WITHIN A FACTOR OF 5 OF OVERFLOW.
* UNDERFLOW IS HARMLESS IF THE INPUT DATA IS 0 OR EXCEEDS
* UNDERFLOW_THRESHOLD / MACHEPS.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
* ..
* .. LOCAL SCALARS ..
DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, SQRT
* ..
* .. EXECUTABLE STATEMENTS ..
*
* COMPUTE THE EIGENVALUES
*
SM = A + C
DF = A - C
ADF = ABS( DF )
TB = B + B
AB = ABS( TB )
IF( ABS( A ).GT.ABS( C ) ) THEN
ACMX = A
ACMN = C
ELSE
ACMX = C
ACMN = A
END IF
IF( ADF.GT.AB ) THEN
RT = ADF*SQRT( ONE+( AB / ADF )**2 )
ELSE IF( ADF.LT.AB ) THEN
RT = AB*SQRT( ONE+( ADF / AB )**2 )
ELSE
*
* INCLUDES CASE AB=ADF=0
*
RT = AB*SQRT( TWO )
END IF
IF( SM.LT.ZERO ) THEN
RT1 = HALF*( SM-RT )
*
* ORDER OF EXECUTION IMPORTANT.
* TO GET FULLY ACCURATE SMALLER EIGENVALUE,
* NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE IF( SM.GT.ZERO ) THEN
RT1 = HALF*( SM+RT )
*
* ORDER OF EXECUTION IMPORTANT.
* TO GET FULLY ACCURATE SMALLER EIGENVALUE,
* NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE
*
* INCLUDES CASE RT1 = RT2 = 0
*
RT1 = HALF*RT
RT2 = -HALF*RT
END IF
RETURN
*
* END OF DLAE2
*
END
CUT HERE............
CAT > DSYTRD.F <<'CUT HERE............'
SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ),
$ WORK( * )
* ..
*
* PURPOSE
* =======
*
* DSYTRD REDUCES A REAL SYMMETRIC MATRIX A TO REAL SYMMETRIC
* TRIDIAGONAL FORM T BY AN ORTHOGONAL SIMILARITY TRANSFORMATION:
* Q**T * A * Q = T.
*
* ARGUMENTS
* =========
*
* UPLO (INPUT) CHARACTER*1
* = 'U': UPPER TRIANGLE OF A IS STORED;
* = 'L': LOWER TRIANGLE OF A IS STORED.
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX A. N >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING
* N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE UPPER
* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY LOWER
* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE
* LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS THE LOWER
* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY UPPER
* TRIANGULAR PART OF A IS NOT REFERENCED.
* ON EXIT, IF UPLO = 'U', THE DIAGONAL AND FIRST SUPERDIAGONAL
* OF A ARE OVERWRITTEN BY THE CORRESPONDING ELEMENTS OF THE
* TRIDIAGONAL MATRIX T, AND THE ELEMENTS ABOVE THE FIRST
* SUPERDIAGONAL, WITH THE ARRAY TAU, REPRESENT THE ORTHOGONAL
* MATRIX Q AS A PRODUCT OF ELEMENTARY REFLECTORS; IF UPLO
* = 'L', THE DIAGONAL AND FIRST SUBDIAGONAL OF A ARE OVER-
* WRITTEN BY THE CORRESPONDING ELEMENTS OF THE TRIDIAGONAL
* MATRIX T, AND THE ELEMENTS BELOW THE FIRST SUBDIAGONAL, WITH
* THE ARRAY TAU, REPRESENT THE ORTHOGONAL MATRIX Q AS A PRODUCT
* OF ELEMENTARY REFLECTORS. SEE FURTHER DETAILS.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N).
*
* D (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T:
* D(I) = A(I,I).
*
* E (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* THE OFF-DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T:
* E(I) = A(I,I+1) IF UPLO = 'U', E(I) = A(I+1,I) IF UPLO = 'L'.
*
* TAU (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS (SEE FURTHER
* DETAILS).
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK)
* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK.
*
* LWORK (INPUT) INTEGER
* THE DIMENSION OF THE ARRAY WORK. LWORK >= 1.
* FOR OPTIMUM PERFORMANCE LWORK >= N*NB, WHERE NB IS THE
* OPTIMAL BLOCKSIZE.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
*
* FURTHER DETAILS
* ===============
*
* IF UPLO = 'U', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY
* REFLECTORS
*
* Q = H(N-1) . . . H(2) H(1).
*
* EACH H(I) HAS THE FORM
*
* H(I) = I - TAU * V * V'
*
* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH
* V(I+1:N) = 0 AND V(I) = 1; V(1:I-1) IS STORED ON EXIT IN
* A(1:I-1,I+1), AND TAU IN TAU(I).
*
* IF UPLO = 'L', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY
* REFLECTORS
*
* Q = H(1) H(2) . . . H(N-1).
*
* EACH H(I) HAS THE FORM
*
* H(I) = I - TAU * V * V'
*
* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH
* V(1:I) = 0 AND V(I+1) = 1; V(I+2:N) IS STORED ON EXIT IN A(I+2:N,I),
* AND TAU IN TAU(I).
*
* THE CONTENTS OF A ON EXIT ARE ILLUSTRATED BY THE FOLLOWING EXAMPLES
* WITH N = 5:
*
* IF UPLO = 'U': IF UPLO = 'L':
*
* ( D E V2 V3 V4 ) ( D )
* ( D E V3 V4 ) ( E D )
* ( D E V4 ) ( V1 E D )
* ( D E ) ( V1 V2 E D )
* ( D ) ( V1 V2 V3 E D )
*
* WHERE D AND E DENOTE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF T, AND VI
* DENOTES AN ELEMENT OF THE VECTOR DEFINING H(I).
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. LOCAL SCALARS ..
LOGICAL UPPER
INTEGER I, IINFO, IWS, J, KK, LDWORK, NB, NBMIN, NX
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTRD', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* DETERMINE THE BLOCK SIZE.
*
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
NX = N
IWS = 1
IF( NB.GT.1 .AND. NB.LT.N ) THEN
*
* DETERMINE WHEN TO CROSS OVER FROM BLOCKED TO UNBLOCKED CODE
* (LAST BLOCK IS ALWAYS HANDLED BY UNBLOCKED CODE).
*
NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) )
IF( NX.LT.N ) THEN
*
* DETERMINE IF WORKSPACE IS LARGE ENOUGH FOR BLOCKED CODE.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* NOT ENOUGH WORKSPACE TO USE OPTIMAL NB: DETERMINE THE
* MINIMUM VALUE OF NB, AND REDUCE NB OR FORCE USE OF
* UNBLOCKED CODE BY SETTING NX = N.
*
NB = LWORK / LDWORK
NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 )
IF( NB.LT.NBMIN )
$ NX = N
END IF
ELSE
NX = N
END IF
ELSE
NB = 1
END IF
*
IF( UPPER ) THEN
*
* REDUCE THE UPPER TRIANGLE OF A.
* COLUMNS 1:KK ARE HANDLED BY THE UNBLOCKED METHOD.
*
KK = N - ( ( N-NX+NB-1 ) / NB )*NB
DO 20 I = N - NB + 1, KK + 1, -NB
*
* REDUCE COLUMNS I:I+NB-1 TO TRIDIAGONAL FORM AND FORM THE
* MATRIX W WHICH IS NEEDED TO UPDATE THE UNREDUCED PART OF
* THE MATRIX
*
CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
$ LDWORK )
*
* UPDATE THE UNREDUCED SUBMATRIX A(1:I-1,1:I-1), USING AN
* UPDATE OF THE FORM: A := A - V*W' - W*V'
*
CALL DSYR2K( UPLO, 'NO TRANSPOSE', I-1, NB, -ONE, A( 1, I ),
$ LDA, WORK, LDWORK, ONE, A, LDA )
*
* COPY SUPERDIAGONAL ELEMENTS BACK INTO A, AND DIAGONAL
* ELEMENTS INTO D
*
DO 10 J = I, I + NB - 1
A( J-1, J ) = E( J-1 )
D( J ) = A( J, J )
10 CONTINUE
20 CONTINUE
*
* USE UNBLOCKED CODE TO REDUCE THE LAST OR ONLY BLOCK
*
CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
ELSE
*
* REDUCE THE LOWER TRIANGLE OF A
*
DO 40 I = 1, N - NX, NB
*
* REDUCE COLUMNS I:I+NB-1 TO TRIDIAGONAL FORM AND FORM THE
* MATRIX W WHICH IS NEEDED TO UPDATE THE UNREDUCED PART OF
* THE MATRIX
*
CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
$ TAU( I ), WORK, LDWORK )
*
* UPDATE THE UNREDUCED SUBMATRIX A(I+IB:N,I+IB:N), USING
* AN UPDATE OF THE FORM: A := A - V*W' - W*V'
*
CALL DSYR2K( UPLO, 'NO TRANSPOSE', N-I-NB+1, NB, -ONE,
$ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
$ A( I+NB, I+NB ), LDA )
*
* COPY SUBDIAGONAL ELEMENTS BACK INTO A, AND DIAGONAL
* ELEMENTS INTO D
*
DO 30 J = I, I + NB - 1
A( J+1, J ) = E( J )
D( J ) = A( J, J )
30 CONTINUE
40 CONTINUE
*
* USE UNBLOCKED CODE TO REDUCE THE LAST OR ONLY BLOCK
*
CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
$ TAU( I ), IINFO )
END IF
*
WORK( 1 ) = IWS
RETURN
*
* END OF DSYTRD
*
END
CUT HERE............
CAT > DSYTD2.F <<'CUT HERE............'
SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * )
* ..
*
* PURPOSE
* =======
*
* DSYTD2 REDUCES A REAL SYMMETRIC MATRIX A TO SYMMETRIC TRIDIAGONAL
* FORM T BY AN ORTHOGONAL SIMILARITY TRANSFORMATION: Q' * A * Q = T.
*
* ARGUMENTS
* =========
*
* UPLO (INPUT) CHARACTER*1
* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE
* SYMMETRIC MATRIX A IS STORED:
* = 'U': UPPER TRIANGULAR
* = 'L': LOWER TRIANGULAR
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX A. N >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING
* N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE UPPER
* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY LOWER
* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE
* LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS THE LOWER
* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY UPPER
* TRIANGULAR PART OF A IS NOT REFERENCED.
* ON EXIT, IF UPLO = 'U', THE DIAGONAL AND FIRST SUPERDIAGONAL
* OF A ARE OVERWRITTEN BY THE CORRESPONDING ELEMENTS OF THE
* TRIDIAGONAL MATRIX T, AND THE ELEMENTS ABOVE THE FIRST
* SUPERDIAGONAL, WITH THE ARRAY TAU, REPRESENT THE ORTHOGONAL
* MATRIX Q AS A PRODUCT OF ELEMENTARY REFLECTORS; IF UPLO
* = 'L', THE DIAGONAL AND FIRST SUBDIAGONAL OF A ARE OVER-
* WRITTEN BY THE CORRESPONDING ELEMENTS OF THE TRIDIAGONAL
* MATRIX T, AND THE ELEMENTS BELOW THE FIRST SUBDIAGONAL, WITH
* THE ARRAY TAU, REPRESENT THE ORTHOGONAL MATRIX Q AS A PRODUCT
* OF ELEMENTARY REFLECTORS. SEE FURTHER DETAILS.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N).
*
* D (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N)
* THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T:
* D(I) = A(I,I).
*
* E (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* THE OFF-DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T:
* E(I) = A(I,I+1) IF UPLO = 'U', E(I) = A(I+1,I) IF UPLO = 'L'.
*
* TAU (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS (SEE FURTHER
* DETAILS).
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE.
*
* FURTHER DETAILS
* ===============
*
* IF UPLO = 'U', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY
* REFLECTORS
*
* Q = H(N-1) . . . H(2) H(1).
*
* EACH H(I) HAS THE FORM
*
* H(I) = I - TAU * V * V'
*
* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH
* V(I+1:N) = 0 AND V(I) = 1; V(1:I-1) IS STORED ON EXIT IN
* A(1:I-1,I+1), AND TAU IN TAU(I).
*
* IF UPLO = 'L', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY
* REFLECTORS
*
* Q = H(1) H(2) . . . H(N-1).
*
* EACH H(I) HAS THE FORM
*
* H(I) = I - TAU * V * V'
*
* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH
* V(1:I) = 0 AND V(I+1) = 1; V(I+2:N) IS STORED ON EXIT IN A(I+2:N,I),
* AND TAU IN TAU(I).
*
* THE CONTENTS OF A ON EXIT ARE ILLUSTRATED BY THE FOLLOWING EXAMPLES
* WITH N = 5:
*
* IF UPLO = 'U': IF UPLO = 'L':
*
* ( D E V2 V3 V4 ) ( D )
* ( D E V3 V4 ) ( E D )
* ( D E V4 ) ( V1 E D )
* ( D E ) ( V1 V2 E D )
* ( D ) ( V1 V2 V3 E D )
*
* WHERE D AND E DENOTE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF T, AND VI
* DENOTES AN ELEMENT OF THE VECTOR DEFINING H(I).
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, ZERO, HALF
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0,
$ HALF = 1.0D0 / 2.0D0 )
* ..
* .. LOCAL SCALARS ..
LOGICAL UPPER
INTEGER I
DOUBLE PRECISION ALPHA, TAUI
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX, MIN
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTD2', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* REDUCE THE UPPER TRIANGLE OF A
*
DO 10 I = N - 1, 1, -1
*
* GENERATE ELEMENTARY REFLECTOR H(I) = I - TAU * V * V'
* TO ANNIHILATE A(1:I-1,I+1)
*
CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI )
E( I ) = A( I, I+1 )
*
IF( TAUI.NE.ZERO ) THEN
*
* APPLY H(I) FROM BOTH SIDES TO A(1:I,1:I)
*
A( I, I+1 ) = ONE
*
* COMPUTE X := TAU * A * V STORING X IN TAU(1:I)
*
CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
$ TAU, 1 )
*
* COMPUTE W := X - 1/2 * TAU * (X'*V) * V
*
ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 )
CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
*
* APPLY THE TRANSFORMATION AS A RANK-2 UPDATE:
* A := A - V * W' - W * V'
*
CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
$ LDA )
*
A( I, I+1 ) = E( I )
END IF
D( I+1 ) = A( I+1, I+1 )
TAU( I ) = TAUI
10 CONTINUE
D( 1 ) = A( 1, 1 )
ELSE
*
* REDUCE THE LOWER TRIANGLE OF A
*
DO 20 I = 1, N - 1
*
* GENERATE ELEMENTARY REFLECTOR H(I) = I - TAU * V * V'
* TO ANNIHILATE A(I+2:N,I)
*
CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
$ TAUI )
E( I ) = A( I+1, I )
*
IF( TAUI.NE.ZERO ) THEN
*
* APPLY H(I) FROM BOTH SIDES TO A(I+1:N,I+1:N)
*
A( I+1, I ) = ONE
*
* COMPUTE X := TAU * A * V STORING Y IN TAU(I:N-1)
*
CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, TAU( I ), 1 )
*
* COMPUTE W := X - 1/2 * TAU * (X'*V) * V
*
ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ),
$ 1 )
CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
*
* APPLY THE TRANSFORMATION AS A RANK-2 UPDATE:
* A := A - V * W' - W * V'
*
CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
$ A( I+1, I+1 ), LDA )
*
A( I+1, I ) = E( I )
END IF
D( I ) = A( I, I )
TAU( I ) = TAUI
20 CONTINUE
D( N ) = A( N, N )
END IF
*
RETURN
*
* END OF DSYTD2
*
END
CUT HERE............
CAT > DLATRD.F <<'CUT HERE............'
SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER UPLO
INTEGER LDA, LDW, N, NB
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
* ..
*
* PURPOSE
* =======
*
* DLATRD REDUCES NB ROWS AND COLUMNS OF A REAL SYMMETRIC MATRIX A TO
* SYMMETRIC TRIDIAGONAL FORM BY AN ORTHOGONAL SIMILARITY
* TRANSFORMATION Q' * A * Q, AND RETURNS THE MATRICES V AND W WHICH ARE
* NEEDED TO APPLY THE TRANSFORMATION TO THE UNREDUCED PART OF A.
*
* IF UPLO = 'U', DLATRD REDUCES THE LAST NB ROWS AND COLUMNS OF A
* MATRIX, OF WHICH THE UPPER TRIANGLE IS SUPPLIED;
* IF UPLO = 'L', DLATRD REDUCES THE FIRST NB ROWS AND COLUMNS OF A
* MATRIX, OF WHICH THE LOWER TRIANGLE IS SUPPLIED.
*
* THIS IS AN AUXILIARY ROUTINE CALLED BY DSYTRD.
*
* ARGUMENTS
* =========
*
* UPLO (INPUT) CHARACTER
* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE
* SYMMETRIC MATRIX A IS STORED:
* = 'U': UPPER TRIANGULAR
* = 'L': LOWER TRIANGULAR
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX A.
*
* NB (INPUT) INTEGER
* THE NUMBER OF ROWS AND COLUMNS TO BE REDUCED.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING
* N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE UPPER
* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY LOWER
* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE
* LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS THE LOWER
* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY UPPER
* TRIANGULAR PART OF A IS NOT REFERENCED.
* ON EXIT:
* IF UPLO = 'U', THE LAST NB COLUMNS HAVE BEEN REDUCED TO
* TRIDIAGONAL FORM, WITH THE DIAGONAL ELEMENTS OVERWRITING
* THE DIAGONAL ELEMENTS OF A; THE ELEMENTS ABOVE THE DIAGONAL
* WITH THE ARRAY TAU, REPRESENT THE ORTHOGONAL MATRIX Q AS A
* PRODUCT OF ELEMENTARY REFLECTORS;
* IF UPLO = 'L', THE FIRST NB COLUMNS HAVE BEEN REDUCED TO
* TRIDIAGONAL FORM, WITH THE DIAGONAL ELEMENTS OVERWRITING
* THE DIAGONAL ELEMENTS OF A; THE ELEMENTS BELOW THE DIAGONAL
* WITH THE ARRAY TAU, REPRESENT THE ORTHOGONAL MATRIX Q AS A
* PRODUCT OF ELEMENTARY REFLECTORS.
* SEE FURTHER DETAILS.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= (1,N).
*
* E (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* IF UPLO = 'U', E(N-NB:N-1) CONTAINS THE SUPERDIAGONAL
* ELEMENTS OF THE LAST NB COLUMNS OF THE REDUCED MATRIX;
* IF UPLO = 'L', E(1:NB) CONTAINS THE SUBDIAGONAL ELEMENTS OF
* THE FIRST NB COLUMNS OF THE REDUCED MATRIX.
*
* TAU (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1)
* THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS, STORED IN
* TAU(N-NB:N-1) IF UPLO = 'U', AND IN TAU(1:NB) IF UPLO = 'L'.
* SEE FURTHER DETAILS.
*
* W (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDW,NB)
* THE N-BY-NB MATRIX W REQUIRED TO UPDATE THE UNREDUCED PART
* OF A.
*
* LDW (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY W. LDW >= MAX(1,N).
*
* FURTHER DETAILS
* ===============
*
* IF UPLO = 'U', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY
* REFLECTORS
*
* Q = H(N) H(N-1) . . . H(N-NB+1).
*
* EACH H(I) HAS THE FORM
*
* H(I) = I - TAU * V * V'
*
* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH
* V(I:N) = 0 AND V(I-1) = 1; V(1:I-1) IS STORED ON EXIT IN A(1:I-1,I),
* AND TAU IN TAU(I-1).
*
* IF UPLO = 'L', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY
* REFLECTORS
*
* Q = H(1) H(2) . . . H(NB).
*
* EACH H(I) HAS THE FORM
*
* H(I) = I - TAU * V * V'
*
* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH
* V(1:I) = 0 AND V(I+1) = 1; V(I+1:N) IS STORED ON EXIT IN A(I+1:N,I),
* AND TAU IN TAU(I).
*
* THE ELEMENTS OF THE VECTORS V TOGETHER FORM THE N-BY-NB MATRIX V
* WHICH IS NEEDED, WITH W, TO APPLY THE TRANSFORMATION TO THE UNREDUCED
* PART OF THE MATRIX, USING A SYMMETRIC RANK-2K UPDATE OF THE FORM:
* A := A - V*W' - W*V'.
*
* THE CONTENTS OF A ON EXIT ARE ILLUSTRATED BY THE FOLLOWING EXAMPLES
* WITH N = 5 AND NB = 2:
*
* IF UPLO = 'U': IF UPLO = 'L':
*
* ( A A A V4 V5 ) ( D )
* ( A A V4 V5 ) ( 1 D )
* ( A 1 V5 ) ( V1 1 A )
* ( D 1 ) ( V1 V2 A A )
* ( D ) ( V1 V2 A A A )
*
* WHERE D DENOTES A DIAGONAL ELEMENT OF THE REDUCED MATRIX, A DENOTES
* AN ELEMENT OF THE ORIGINAL MATRIX THAT IS UNCHANGED, AND VI DENOTES
* AN ELEMENT OF THE VECTOR DEFINING H(I).
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO, ONE, HALF
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, IW
DOUBLE PRECISION ALPHA
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MIN
* ..
* .. EXECUTABLE STATEMENTS ..
*
* QUICK RETURN IF POSSIBLE
*
IF( N.LE.0 )
$ RETURN
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* REDUCE LAST NB COLUMNS OF UPPER TRIANGLE
*
DO 10 I = N, N - NB + 1, -1
IW = I - N + NB
IF( I.LT.N ) THEN
*
* UPDATE A(1:I,I)
*
CALL DGEMV( 'NO TRANSPOSE', I, N-I, -ONE, A( 1, I+1 ),
$ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
CALL DGEMV( 'NO TRANSPOSE', I, N-I, -ONE, W( 1, IW+1 ),
$ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
END IF
IF( I.GT.1 ) THEN
*
* GENERATE ELEMENTARY REFLECTOR H(I) TO ANNIHILATE
* A(1:I-2,I)
*
CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) )
E( I-1 ) = A( I-1, I )
A( I-1, I ) = ONE
*
* COMPUTE W(1:I-1,I)
*
CALL DSYMV( 'UPPER', I-1, ONE, A, LDA, A( 1, I ), 1,
$ ZERO, W( 1, IW ), 1 )
IF( I.LT.N ) THEN
CALL DGEMV( 'TRANSPOSE', I-1, N-I, ONE, W( 1, IW+1 ),
$ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
CALL DGEMV( 'NO TRANSPOSE', I-1, N-I, -ONE,
$ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
CALL DGEMV( 'TRANSPOSE', I-1, N-I, ONE, A( 1, I+1 ),
$ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
CALL DGEMV( 'NO TRANSPOSE', I-1, N-I, -ONE,
$ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
END IF
CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1,
$ A( 1, I ), 1 )
CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
END IF
*
10 CONTINUE
ELSE
*
* REDUCE FIRST NB COLUMNS OF LOWER TRIANGLE
*
DO 20 I = 1, NB
*
* UPDATE A(I:N,I)
*
CALL DGEMV( 'NO TRANSPOSE', N-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
CALL DGEMV( 'NO TRANSPOSE', N-I+1, I-1, -ONE, W( I, 1 ),
$ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
IF( I.LT.N ) THEN
*
* GENERATE ELEMENTARY REFLECTOR H(I) TO ANNIHILATE
* A(I+2:N,I)
*
CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
$ TAU( I ) )
E( I ) = A( I+1, I )
A( I+1, I ) = ONE
*
* COMPUTE W(I+1:N,I)
*
CALL DSYMV( 'LOWER', N-I, ONE, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
CALL DGEMV( 'TRANSPOSE', N-I, I-1, ONE, W( I+1, 1 ), LDW,
$ A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
CALL DGEMV( 'NO TRANSPOSE', N-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL DGEMV( 'TRANSPOSE', N-I, I-1, ONE, A( I+1, 1 ), LDA,
$ A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
CALL DGEMV( 'NO TRANSPOSE', N-I, I-1, -ONE, W( I+1, 1 ),
$ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1,
$ A( I+1, I ), 1 )
CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
END IF
*
20 CONTINUE
END IF
*
RETURN
*
* END OF DLATRD
*
END
CUT HERE............
CAT > DLARFG.F <<'CUT HERE............'
SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* FEBRUARY 29, 1992
*
* .. SCALAR ARGUMENTS ..
INTEGER INCX, N
DOUBLE PRECISION ALPHA, TAU
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION X( * )
* ..
*
* PURPOSE
* =======
*
* DLARFG GENERATES A REAL ELEMENTARY REFLECTOR H OF ORDER N, SUCH
* THAT
*
* H * ( ALPHA ) = ( BETA ), H' * H = I.
* ( X ) ( 0 )
*
* WHERE ALPHA AND BETA ARE SCALARS, AND X IS AN (N-1)-ELEMENT REAL
* VECTOR. H IS REPRESENTED IN THE FORM
*
* H = I - TAU * ( 1 ) * ( 1 V' ) ,
* ( V )
*
* WHERE TAU IS A REAL SCALAR AND V IS A REAL (N-1)-ELEMENT
* VECTOR.
*
* IF THE ELEMENTS OF X ARE ALL ZERO, THEN TAU = 0 AND H IS TAKEN TO BE
* THE UNIT MATRIX.
*
* OTHERWISE 1 <= TAU <= 2.
*
* ARGUMENTS
* =========
*
* N (INPUT) INTEGER
* THE ORDER OF THE ELEMENTARY REFLECTOR.
*
* ALPHA (INPUT/OUTPUT) DOUBLE PRECISION
* ON ENTRY, THE VALUE ALPHA.
* ON EXIT, IT IS OVERWRITTEN WITH THE VALUE BETA.
*
* X (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION
* (1+(N-2)*ABS(INCX))
* ON ENTRY, THE VECTOR X.
* ON EXIT, IT IS OVERWRITTEN WITH THE VECTOR V.
*
* INCX (INPUT) INTEGER
* THE INCREMENT BETWEEN ELEMENTS OF X. INCX <> 0.
*
* TAU (OUTPUT) DOUBLE PRECISION
* THE VALUE TAU.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER J, KNT
DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. EXTERNAL FUNCTIONS ..
DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
EXTERNAL DLAMCH, DLAPY2, DNRM2
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, SIGN
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DSCAL
* ..
* .. EXECUTABLE STATEMENTS ..
*
IF( N.LE.1 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = DNRM2( N-1, X, INCX )
*
IF( XNORM.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* GENERAL CASE
*
BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
SAFMIN = DLAMCH( 'S' )
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA MAY BE INACCURATE; SCALE X AND RECOMPUTE THEM
*
RSAFMN = ONE / SAFMIN
KNT = 0
10 CONTINUE
KNT = KNT + 1
CALL DSCAL( N-1, RSAFMN, X, INCX )
BETA = BETA*RSAFMN
ALPHA = ALPHA*RSAFMN
IF( ABS( BETA ).LT.SAFMIN )
$ GO TO 10
*
* NEW BETA IS AT MOST 1, AT LEAST SAFMIN
*
XNORM = DNRM2( N-1, X, INCX )
BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
TAU = ( BETA-ALPHA ) / BETA
CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
*
* IF ALPHA IS SUBNORMAL, IT MAY LOSE RELATIVE ACCURACY
*
ALPHA = BETA
DO 20 J = 1, KNT
ALPHA = ALPHA*SAFMIN
20 CONTINUE
ELSE
TAU = ( BETA-ALPHA ) / BETA
CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
ALPHA = BETA
END IF
END IF
*
RETURN
*
* END OF DLARFG
*
END
CUT HERE............
CAT > DLAMCH.F <<'CUT HERE............'
DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER CMACH
* ..
*
* PURPOSE
* =======
*
* DLAMCH DETERMINES DOUBLE PRECISION MACHINE PARAMETERS.
*
* ARGUMENTS
* =========
*
* CMACH (INPUT) CHARACTER*1
* SPECIFIES THE VALUE TO BE RETURNED BY DLAMCH:
* = 'E' OR 'E', DLAMCH := EPS
* = 'S' OR 'S , DLAMCH := SFMIN
* = 'B' OR 'B', DLAMCH := BASE
* = 'P' OR 'P', DLAMCH := EPS*BASE
* = 'N' OR 'N', DLAMCH := T
* = 'R' OR 'R', DLAMCH := RND
* = 'M' OR 'M', DLAMCH := EMIN
* = 'U' OR 'U', DLAMCH := RMIN
* = 'L' OR 'L', DLAMCH := EMAX
* = 'O' OR 'O', DLAMCH := RMAX
*
* WHERE
*
* EPS = RELATIVE MACHINE PRECISION
* SFMIN = SAFE MINIMUM, SUCH THAT 1/SFMIN DOES NOT OVERFLOW
* BASE = BASE OF THE MACHINE
* PREC = EPS*BASE
* T = NUMBER OF (BASE) DIGITS IN THE MANTISSA
* RND = 1.0 WHEN ROUNDING OCCURS IN ADDITION, 0.0 OTHERWISE
* EMIN = MINIMUM EXPONENT BEFORE (GRADUAL) UNDERFLOW
* RMIN = UNDERFLOW THRESHOLD - BASE**(EMIN-1)
* EMAX = LARGEST EXPONENT BEFORE OVERFLOW
* RMAX = OVERFLOW THRESHOLD - (BASE**EMAX)*(1-EPS)
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
LOGICAL FIRST, LRND
INTEGER BETA, IMAX, IMIN, IT
DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
$ RND, SFMIN, SMALL, T
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLAMC2
* ..
* .. SAVE STATEMENT ..
SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
$ EMAX, RMAX, PREC
* ..
* .. DATA STATEMENTS ..
DATA FIRST / .TRUE. /
* ..
* .. EXECUTABLE STATEMENTS ..
*
IF( FIRST ) THEN
FIRST = .FALSE.
CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
BASE = BETA
T = IT
IF( LRND ) THEN
RND = ONE
EPS = ( BASE**( 1-IT ) ) / 2
ELSE
RND = ZERO
EPS = BASE**( 1-IT )
END IF
PREC = EPS*BASE
EMIN = IMIN
EMAX = IMAX
SFMIN = RMIN
SMALL = ONE / RMAX
IF( SMALL.GE.SFMIN ) THEN
*
* USE SMALL PLUS A BIT, TO AVOID THE POSSIBILITY OF ROUNDING
* CAUSING OVERFLOW WHEN COMPUTING 1/SFMIN.
*
SFMIN = SMALL*( ONE+EPS )
END IF
END IF
*
IF( LSAME( CMACH, 'E' ) ) THEN
RMACH = EPS
ELSE IF( LSAME( CMACH, 'S' ) ) THEN
RMACH = SFMIN
ELSE IF( LSAME( CMACH, 'B' ) ) THEN
RMACH = BASE
ELSE IF( LSAME( CMACH, 'P' ) ) THEN
RMACH = PREC
ELSE IF( LSAME( CMACH, 'N' ) ) THEN
RMACH = T
ELSE IF( LSAME( CMACH, 'R' ) ) THEN
RMACH = RND
ELSE IF( LSAME( CMACH, 'M' ) ) THEN
RMACH = EMIN
ELSE IF( LSAME( CMACH, 'U' ) ) THEN
RMACH = RMIN
ELSE IF( LSAME( CMACH, 'L' ) ) THEN
RMACH = EMAX
ELSE IF( LSAME( CMACH, 'O' ) ) THEN
RMACH = RMAX
END IF
*
DLAMCH = RMACH
RETURN
*
* END OF DLAMCH
*
END
*
************************************************************************
*
SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
LOGICAL IEEE1, RND
INTEGER BETA, T
* ..
*
* PURPOSE
* =======
*
* DLAMC1 DETERMINES THE MACHINE PARAMETERS GIVEN BY BETA, T, RND, AND
* IEEE1.
*
* ARGUMENTS
* =========
*
* BETA (OUTPUT) INTEGER
* THE BASE OF THE MACHINE.
*
* T (OUTPUT) INTEGER
* THE NUMBER OF ( BETA ) DIGITS IN THE MANTISSA.
*
* RND (OUTPUT) LOGICAL
* SPECIFIES WHETHER PROPER ROUNDING ( RND = .TRUE. ) OR
* CHOPPING ( RND = .FALSE. ) OCCURS IN ADDITION. THIS MAY NOT
* BE A RELIABLE GUIDE TO THE WAY IN WHICH THE MACHINE PERFORMS
* ITS ARITHMETIC.
*
* IEEE1 (OUTPUT) LOGICAL
* SPECIFIES WHETHER ROUNDING APPEARS TO BE DONE IN THE IEEE
* 'ROUND TO NEAREST' STYLE.
*
* FURTHER DETAILS
* ===============
*
* THE ROUTINE IS BASED ON THE ROUTINE ENVRON BY MALCOLM AND
* INCORPORATES SUGGESTIONS BY GENTLEMAN AND MAROVICH. SEE
*
* MALCOLM M. A. (1972) ALGORITHMS TO REVEAL PROPERTIES OF
* FLOATING-POINT ARITHMETIC. COMMS. OF THE ACM, 15, 949-951.
*
* GENTLEMAN W. M. AND MAROVICH S. B. (1974) MORE ON ALGORITHMS
* THAT REVEAL PROPERTIES OF FLOATING POINT ARITHMETIC UNITS.
* COMMS. OF THE ACM, 17, 276-277.
*
* =====================================================================
*
* .. LOCAL SCALARS ..
LOGICAL FIRST, LIEEE1, LRND
INTEGER LBETA, LT
DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2
* ..
* .. EXTERNAL FUNCTIONS ..
DOUBLE PRECISION DLAMC3
EXTERNAL DLAMC3
* ..
* .. SAVE STATEMENT ..
SAVE FIRST, LIEEE1, LBETA, LRND, LT
* ..
* .. DATA STATEMENTS ..
DATA FIRST / .TRUE. /
* ..
* .. EXECUTABLE STATEMENTS ..
*
IF( FIRST ) THEN
FIRST = .FALSE.
ONE = 1
*
* LBETA, LIEEE1, LT AND LRND ARE THE LOCAL VALUES OF BETA,
* IEEE1, T AND RND.
*
* THROUGHOUT THIS ROUTINE WE USE THE FUNCTION DLAMC3 TO ENSURE
* THAT RELEVANT VALUES ARE STORED AND NOT HELD IN REGISTERS, OR
* ARE NOT AFFECTED BY OPTIMIZERS.
*
* COMPUTE A = 2.0**M WITH THE SMALLEST POSITIVE INTEGER M SUCH
* THAT
*
* FL( A + 1.0 ) = A.
*
A = 1
C = 1
*
*+ WHILE( C.EQ.ONE )LOOP
10 CONTINUE
IF( C.EQ.ONE ) THEN
A = 2*A
C = DLAMC3( A, ONE )
C = DLAMC3( C, -A )
GO TO 10
END IF
*+ END WHILE
*
* NOW COMPUTE B = 2.0**M WITH THE SMALLEST POSITIVE INTEGER M
* SUCH THAT
*
* FL( A + B ) .GT. A.
*
B = 1
C = DLAMC3( A, B )
*
*+ WHILE( C.EQ.A )LOOP
20 CONTINUE
IF( C.EQ.A ) THEN
B = 2*B
C = DLAMC3( A, B )
GO TO 20
END IF
*+ END WHILE
*
* NOW COMPUTE THE BASE. A AND C ARE NEIGHBOURING FLOATING POINT
* NUMBERS IN THE INTERVAL ( BETA**T, BETA**( T + 1 ) ) AND SO
* THEIR DIFFERENCE IS BETA. ADDING 0.25 TO C IS TO ENSURE THAT IT
* IS TRUNCATED TO BETA AND NOT ( BETA - 1 ).
*
QTR = ONE / 4
SAVEC = C
C = DLAMC3( C, -A )
LBETA = C + QTR
*
* NOW DETERMINE WHETHER ROUNDING OR CHOPPING OCCURS, BY ADDING A
* BIT LESS THAN BETA/2 AND A BIT MORE THAN BETA/2 TO A.
*
B = LBETA
F = DLAMC3( B / 2, -B / 100 )
C = DLAMC3( F, A )
IF( C.EQ.A ) THEN
LRND = .TRUE.
ELSE
LRND = .FALSE.
END IF
F = DLAMC3( B / 2, B / 100 )
C = DLAMC3( F, A )
IF( ( LRND ) .AND. ( C.EQ.A ) )
$ LRND = .FALSE.
*
* TRY AND DECIDE WHETHER ROUNDING IS DONE IN THE IEEE 'ROUND TO
* NEAREST' STYLE. B/2 IS HALF A UNIT IN THE LAST PLACE OF THE TWO
* NUMBERS A AND SAVEC. FURTHERMORE, A IS EVEN, I.E. HAS LAST BIT
* ZERO, AND SAVEC IS ODD. THUS ADDING B/2 TO A SHOULD NOT CHANGE
* A, BUT ADDING B/2 TO SAVEC SHOULD CHANGE SAVEC.
*
T1 = DLAMC3( B / 2, A )
T2 = DLAMC3( B / 2, SAVEC )
LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
*
* NOW FIND THE MANTISSA, T. IT SHOULD BE THE INTEGER PART OF
* LOG TO THE BASE BETA OF A, HOWEVER IT IS SAFER TO DETERMINE T
* BY POWERING. SO WE FIND T AS THE SMALLEST POSITIVE INTEGER FOR
* WHICH
*
* FL( BETA**T + 1.0 ) = 1.0.
*
LT = 0
A = 1
C = 1
*
*+ WHILE( C.EQ.ONE )LOOP
30 CONTINUE
IF( C.EQ.ONE ) THEN
LT = LT + 1
A = A*LBETA
C = DLAMC3( A, ONE )
C = DLAMC3( C, -A )
GO TO 30
END IF
*+ END WHILE
*
END IF
*
BETA = LBETA
T = LT
RND = LRND
IEEE1 = LIEEE1
RETURN
*
* END OF DLAMC1
*
END
*
************************************************************************
*
SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
LOGICAL RND
INTEGER BETA, EMAX, EMIN, T
DOUBLE PRECISION EPS, RMAX, RMIN
* ..
*
* PURPOSE
* =======
*
* DLAMC2 DETERMINES THE MACHINE PARAMETERS SPECIFIED IN ITS ARGUMENT
* LIST.
*
* ARGUMENTS
* =========
*
* BETA (OUTPUT) INTEGER
* THE BASE OF THE MACHINE.
*
* T (OUTPUT) INTEGER
* THE NUMBER OF ( BETA ) DIGITS IN THE MANTISSA.
*
* RND (OUTPUT) LOGICAL
* SPECIFIES WHETHER PROPER ROUNDING ( RND = .TRUE. ) OR
* CHOPPING ( RND = .FALSE. ) OCCURS IN ADDITION. THIS MAY NOT
* BE A RELIABLE GUIDE TO THE WAY IN WHICH THE MACHINE PERFORMS
* ITS ARITHMETIC.
*
* EPS (OUTPUT) DOUBLE PRECISION
* THE SMALLEST POSITIVE NUMBER SUCH THAT
*
* FL( 1.0 - EPS ) .LT. 1.0,
*
* WHERE FL DENOTES THE COMPUTED VALUE.
*
* EMIN (OUTPUT) INTEGER
* THE MINIMUM EXPONENT BEFORE (GRADUAL) UNDERFLOW OCCURS.
*
* RMIN (OUTPUT) DOUBLE PRECISION
* THE SMALLEST NORMALIZED NUMBER FOR THE MACHINE, GIVEN BY
* BASE**( EMIN - 1 ), WHERE BASE IS THE FLOATING POINT VALUE
* OF BETA.
*
* EMAX (OUTPUT) INTEGER
* THE MAXIMUM EXPONENT BEFORE OVERFLOW OCCURS.
*
* RMAX (OUTPUT) DOUBLE PRECISION
* THE LARGEST POSITIVE NUMBER FOR THE MACHINE, GIVEN BY
* BASE**EMAX * ( 1 - EPS ), WHERE BASE IS THE FLOATING POINT
* VALUE OF BETA.
*
* FURTHER DETAILS
* ===============
*
* THE COMPUTATION OF EPS IS BASED ON A ROUTINE PARANOIA BY
* W. KAHAN OF THE UNIVERSITY OF CALIFORNIA AT BERKELEY.
*
* =====================================================================
*
* .. LOCAL SCALARS ..
LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND
INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
$ NGNMIN, NGPMIN
DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
$ SIXTH, SMALL, THIRD, TWO, ZERO
* ..
* .. EXTERNAL FUNCTIONS ..
DOUBLE PRECISION DLAMC3
EXTERNAL DLAMC3
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLAMC1, DLAMC4, DLAMC5
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, MAX, MIN
* ..
* .. SAVE STATEMENT ..
SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
$ LRMIN, LT
* ..
* .. DATA STATEMENTS ..
DATA FIRST / .TRUE. / , IWARN / .FALSE. /
* ..
* .. EXECUTABLE STATEMENTS ..
*
IF( FIRST ) THEN
FIRST = .FALSE.
ZERO = 0
ONE = 1
TWO = 2
*
* LBETA, LT, LRND, LEPS, LEMIN AND LRMIN ARE THE LOCAL VALUES OF
* BETA, T, RND, EPS, EMIN AND RMIN.
*
* THROUGHOUT THIS ROUTINE WE USE THE FUNCTION DLAMC3 TO ENSURE
* THAT RELEVANT VALUES ARE STORED AND NOT HELD IN REGISTERS, OR
* ARE NOT AFFECTED BY OPTIMIZERS.
*
* DLAMC1 RETURNS THE PARAMETERS LBETA, LT, LRND AND LIEEE1.
*
CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
*
* START TO FIND EPS.
*
B = LBETA
A = B**( -LT )
LEPS = A
*
* TRY SOME TRICKS TO SEE WHETHER OR NOT THIS IS THE CORRECT EPS.
*
B = TWO / 3
HALF = ONE / 2
SIXTH = DLAMC3( B, -HALF )
THIRD = DLAMC3( SIXTH, SIXTH )
B = DLAMC3( THIRD, -HALF )
B = DLAMC3( B, SIXTH )
B = ABS( B )
IF( B.LT.LEPS )
$ B = LEPS
*
LEPS = 1
*
*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
10 CONTINUE
IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
LEPS = B
C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
C = DLAMC3( HALF, -C )
B = DLAMC3( HALF, C )
C = DLAMC3( HALF, -B )
B = DLAMC3( HALF, C )
GO TO 10
END IF
*+ END WHILE
*
IF( A.LT.LEPS )
$ LEPS = A
*
* COMPUTATION OF EPS COMPLETE.
*
* NOW FIND EMIN. LET A = + OR - 1, AND + OR - (1 + BASE**(-3)).
* KEEP DIVIDING A BY BETA UNTIL (GRADUAL) UNDERFLOW OCCURS. THIS
* IS DETECTED WHEN WE CANNOT RECOVER THE PREVIOUS A.
*
RBASE = ONE / LBETA
SMALL = ONE
DO 20 I = 1, 3
SMALL = DLAMC3( SMALL*RBASE, ZERO )
20 CONTINUE
A = DLAMC3( ONE, SMALL )
CALL DLAMC4( NGPMIN, ONE, LBETA )
CALL DLAMC4( NGNMIN, -ONE, LBETA )
CALL DLAMC4( GPMIN, A, LBETA )
CALL DLAMC4( GNMIN, -A, LBETA )
IEEE = .FALSE.
*
IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
IF( NGPMIN.EQ.GPMIN ) THEN
LEMIN = NGPMIN
* ( NON TWOS-COMPLEMENT MACHINES, NO GRADUAL UNDERFLOW;
* E.G., VAX )
ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
LEMIN = NGPMIN - 1 + LT
IEEE = .TRUE.
* ( NON TWOS-COMPLEMENT MACHINES, WITH GRADUAL UNDERFLOW;
* E.G., IEEE STANDARD FOLLOWERS )
ELSE
LEMIN = MIN( NGPMIN, GPMIN )
* ( A GUESS; NO KNOWN MACHINE )
IWARN = .TRUE.
END IF
*
ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
LEMIN = MAX( NGPMIN, NGNMIN )
* ( TWOS-COMPLEMENT MACHINES, NO GRADUAL UNDERFLOW;
* E.G., CYBER 205 )
ELSE
LEMIN = MIN( NGPMIN, NGNMIN )
* ( A GUESS; NO KNOWN MACHINE )
IWARN = .TRUE.
END IF
*
ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
$ ( GPMIN.EQ.GNMIN ) ) THEN
IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
* ( TWOS-COMPLEMENT MACHINES WITH GRADUAL UNDERFLOW;
* NO KNOWN MACHINE )
ELSE
LEMIN = MIN( NGPMIN, NGNMIN )
* ( A GUESS; NO KNOWN MACHINE )
IWARN = .TRUE.
END IF
*
ELSE
LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
* ( A GUESS; NO KNOWN MACHINE )
IWARN = .TRUE.
END IF
***
* COMMENT OUT THIS IF BLOCK IF EMIN IS OK
IF( IWARN ) THEN
FIRST = .TRUE.
WRITE( 6, FMT = 9999 )LEMIN
END IF
***
*
* ASSUME IEEE ARITHMETIC IF WE FOUND DENORMALISED NUMBERS ABOVE,
* OR IF ARITHMETIC SEEMS TO ROUND IN THE IEEE STYLE, DETERMINED
* IN ROUTINE DLAMC1. A TRUE IEEE MACHINE SHOULD HAVE BOTH THINGS
* TRUE; HOWEVER, FAULTY MACHINES MAY HAVE ONE OR THE OTHER.
*
IEEE = IEEE .OR. LIEEE1
*
* COMPUTE RMIN BY SUCCESSIVE DIVISION BY BETA. WE COULD COMPUTE
* RMIN AS BASE**( EMIN - 1 ), BUT SOME MACHINES UNDERFLOW DURING
* THIS COMPUTATION.
*
LRMIN = 1
DO 30 I = 1, 1 - LEMIN
LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
30 CONTINUE
*
* FINALLY, CALL DLAMC5 TO COMPUTE EMAX AND RMAX.
*
CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
END IF
*
BETA = LBETA
T = LT
RND = LRND
EPS = LEPS
EMIN = LEMIN
RMIN = LRMIN
EMAX = LEMAX
RMAX = LRMAX
*
RETURN
*
9999 FORMAT( / / ' WARNING. THE VALUE EMIN MAY BE INCORRECT:-',
$ ' EMIN = ', I8, /
$ ' IF, AFTER INSPECTION, THE VALUE EMIN LOOKS',
$ ' ACCEPTABLE PLEASE COMMENT OUT ',
$ / ' THE IF BLOCK AS MARKED WITHIN THE CODE OF ROUTINE',
$ ' DLAMC2,', / ' OTHERWISE SUPPLY EMIN EXPLICITLY.', / )
*
* END OF DLAMC2
*
END
*
************************************************************************
*
DOUBLE PRECISION FUNCTION DLAMC3( A, B )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
DOUBLE PRECISION A, B
* ..
*
* PURPOSE
* =======
*
* DLAMC3 IS INTENDED TO FORCE A AND B TO BE STORED PRIOR TO DOING
* THE ADDITION OF A AND B , FOR USE IN SITUATIONS WHERE OPTIMIZERS
* MIGHT HOLD ONE OF THESE IN A REGISTER.
*
* ARGUMENTS
* =========
*
* A, B (INPUT) DOUBLE PRECISION
* THE VALUES A AND B.
*
* =====================================================================
*
* .. EXECUTABLE STATEMENTS ..
*
DLAMC3 = A + B
*
RETURN
*
* END OF DLAMC3
*
END
*
************************************************************************
*
SUBROUTINE DLAMC4( EMIN, START, BASE )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
INTEGER BASE, EMIN
DOUBLE PRECISION START
* ..
*
* PURPOSE
* =======
*
* DLAMC4 IS A SERVICE ROUTINE FOR DLAMC2.
*
* ARGUMENTS
* =========
*
* EMIN (OUTPUT) EMIN
* THE MINIMUM EXPONENT BEFORE (GRADUAL) UNDERFLOW, COMPUTED BY
* SETTING A = START AND DIVIDING BY BASE UNTIL THE PREVIOUS A
* CAN NOT BE RECOVERED.
*
* START (INPUT) DOUBLE PRECISION
* THE STARTING POINT FOR DETERMINING EMIN.
*
* BASE (INPUT) INTEGER
* THE BASE OF THE MACHINE.
*
* =====================================================================
*
* .. LOCAL SCALARS ..
INTEGER I
DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
* ..
* .. EXTERNAL FUNCTIONS ..
DOUBLE PRECISION DLAMC3
EXTERNAL DLAMC3
* ..
* .. EXECUTABLE STATEMENTS ..
*
A = START
ONE = 1
RBASE = ONE / BASE
ZERO = 0
EMIN = 1
B1 = DLAMC3( A*RBASE, ZERO )
C1 = A
C2 = A
D1 = A
D2 = A
*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP
10 CONTINUE
IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
$ ( D2.EQ.A ) ) THEN
EMIN = EMIN - 1
A = B1
B1 = DLAMC3( A / BASE, ZERO )
C1 = DLAMC3( B1*BASE, ZERO )
D1 = ZERO
DO 20 I = 1, BASE
D1 = D1 + B1
20 CONTINUE
B2 = DLAMC3( A*RBASE, ZERO )
C2 = DLAMC3( B2 / RBASE, ZERO )
D2 = ZERO
DO 30 I = 1, BASE
D2 = D2 + B2
30 CONTINUE
GO TO 10
END IF
*+ END WHILE
*
RETURN
*
* END OF DLAMC4
*
END
*
************************************************************************
*
SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
LOGICAL IEEE
INTEGER BETA, EMAX, EMIN, P
DOUBLE PRECISION RMAX
* ..
*
* PURPOSE
* =======
*
* DLAMC5 ATTEMPTS TO COMPUTE RMAX, THE LARGEST MACHINE FLOATING-POINT
* NUMBER, WITHOUT OVERFLOW. IT ASSUMES THAT EMAX + ABS(EMIN) SUM
* APPROXIMATELY TO A POWER OF 2. IT WILL FAIL ON MACHINES WHERE THIS
* ASSUMPTION DOES NOT HOLD, FOR EXAMPLE, THE CYBER 205 (EMIN = -28625,
* EMAX = 28718). IT WILL ALSO FAIL IF THE VALUE SUPPLIED FOR EMIN IS
* TOO LARGE (I.E. TOO CLOSE TO ZERO), PROBABLY WITH OVERFLOW.
*
* ARGUMENTS
* =========
*
* BETA (INPUT) INTEGER
* THE BASE OF FLOATING-POINT ARITHMETIC.
*
* P (INPUT) INTEGER
* THE NUMBER OF BASE BETA DIGITS IN THE MANTISSA OF A
* FLOATING-POINT VALUE.
*
* EMIN (INPUT) INTEGER
* THE MINIMUM EXPONENT BEFORE (GRADUAL) UNDERFLOW.
*
* IEEE (INPUT) LOGICAL
* A LOGICAL FLAG SPECIFYING WHETHER OR NOT THE ARITHMETIC
* SYSTEM IS THOUGHT TO COMPLY WITH THE IEEE STANDARD.
*
* EMAX (OUTPUT) INTEGER
* THE LARGEST EXPONENT BEFORE OVERFLOW
*
* RMAX (OUTPUT) DOUBLE PRECISION
* THE LARGEST MACHINE FLOATING-POINT NUMBER.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. LOCAL SCALARS ..
INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
DOUBLE PRECISION OLDY, RECBAS, Y, Z
* ..
* .. EXTERNAL FUNCTIONS ..
DOUBLE PRECISION DLAMC3
EXTERNAL DLAMC3
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MOD
* ..
* .. EXECUTABLE STATEMENTS ..
*
* FIRST COMPUTE LEXP AND UEXP, TWO POWERS OF 2 THAT BOUND
* ABS(EMIN). WE THEN ASSUME THAT EMAX + ABS(EMIN) WILL SUM
* APPROXIMATELY TO THE BOUND THAT IS CLOSEST TO ABS(EMIN).
* (EMAX IS THE EXPONENT OF THE REQUIRED NUMBER RMAX).
*
LEXP = 1
EXBITS = 1
10 CONTINUE
TRY = LEXP*2
IF( TRY.LE.( -EMIN ) ) THEN
LEXP = TRY
EXBITS = EXBITS + 1
GO TO 10
END IF
IF( LEXP.EQ.-EMIN ) THEN
UEXP = LEXP
ELSE
UEXP = TRY
EXBITS = EXBITS + 1
END IF
*
* NOW -LEXP IS LESS THAN OR EQUAL TO EMIN, AND -UEXP IS GREATER
* THAN OR EQUAL TO EMIN. EXBITS IS THE NUMBER OF BITS NEEDED TO
* STORE THE EXPONENT.
*
IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
EXPSUM = 2*LEXP
ELSE
EXPSUM = 2*UEXP
END IF
*
* EXPSUM IS THE EXPONENT RANGE, APPROXIMATELY EQUAL TO
* EMAX - EMIN + 1 .
*
EMAX = EXPSUM + EMIN - 1
NBITS = 1 + EXBITS + P
*
* NBITS IS THE TOTAL NUMBER OF BITS NEEDED TO STORE A
* FLOATING-POINT NUMBER.
*
IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
*
* EITHER THERE ARE AN ODD NUMBER OF BITS USED TO STORE A
* FLOATING-POINT NUMBER, WHICH IS UNLIKELY, OR SOME BITS ARE
* NOT USED IN THE REPRESENTATION OF NUMBERS, WHICH IS POSSIBLE,
* (E.G. CRAY MACHINES) OR THE MANTISSA HAS AN IMPLICIT BIT,
* (E.G. IEEE MACHINES, DEC VAX MACHINES), WHICH IS PERHAPS THE
* MOST LIKELY. WE HAVE TO ASSUME THE LAST ALTERNATIVE.
* IF THIS IS TRUE, THEN WE NEED TO REDUCE EMAX BY ONE BECAUSE
* THERE MUST BE SOME WAY OF REPRESENTING ZERO IN AN IMPLICIT-BIT
* SYSTEM. ON MACHINES LIKE CRAY, WE ARE REDUCING EMAX BY ONE
* UNNECESSARILY.
*
EMAX = EMAX - 1
END IF
*
IF( IEEE ) THEN
*
* ASSUME WE ARE ON AN IEEE MACHINE WHICH RESERVES ONE EXPONENT
* FOR INFINITY AND NAN.
*
EMAX = EMAX - 1
END IF
*
* NOW CREATE RMAX, THE LARGEST MACHINE NUMBER, WHICH SHOULD
* BE EQUAL TO (1.0 - BETA**(-P)) * BETA**EMAX .
*
* FIRST COMPUTE 1.0 - BETA**(-P), BEING CAREFUL THAT THE
* RESULT IS LESS THAN 1.0 .
*
RECBAS = ONE / BETA
Z = BETA - ONE
Y = ZERO
DO 20 I = 1, P
Z = Z*RECBAS
IF( Y.LT.ONE )
$ OLDY = Y
Y = DLAMC3( Y, Z )
20 CONTINUE
IF( Y.GE.ONE )
$ Y = OLDY
*
* NOW MULTIPLY BY BETA**EMAX TO GET RMAX.
*
DO 30 I = 1, EMAX
Y = DLAMC3( Y*BETA, ZERO )
30 CONTINUE
*
RMAX = Y
RETURN
*
* END OF DLAMC5
*
END
CUT HERE............
CAT > DLAPY2.F <<'CUT HERE............'
DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
DOUBLE PRECISION X, Y
* ..
*
* PURPOSE
* =======
*
* DLAPY2 RETURNS SQRT(X**2+Y**2), TAKING CARE NOT TO CAUSE UNNECESSARY
* OVERFLOW.
*
* ARGUMENTS
* =========
*
* X (INPUT) DOUBLE PRECISION
* Y (INPUT) DOUBLE PRECISION
* X AND Y SPECIFY THE VALUES X AND Y.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. LOCAL SCALARS ..
DOUBLE PRECISION W, XABS, YABS, Z
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. EXECUTABLE STATEMENTS ..
*
XABS = ABS( X )
YABS = ABS( Y )
W = MAX( XABS, YABS )
Z = MIN( XABS, YABS )
IF( Z.EQ.ZERO ) THEN
DLAPY2 = W
ELSE
DLAPY2 = W*SQRT( ONE+( Z / W )**2 )
END IF
RETURN
*
* END OF DLAPY2
*
END
CUT HERE............
CAT > ILAENV.F <<'CUT HERE............'
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
$ N4 )
*
* -- LAPACK AUXILIARY ROUTINE (PRELIMINARY VERSION) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* FEBRUARY 20, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER*( * ) NAME, OPTS
INTEGER ISPEC, N1, N2, N3, N4
* ..
*
* PURPOSE
* =======
*
* ILAENV IS CALLED FROM THE LAPACK ROUTINES TO CHOOSE PROBLEM-DEPENDENT
* PARAMETERS FOR THE LOCAL ENVIRONMENT. SEE ISPEC FOR A DESCRIPTION OF
* THE PARAMETERS.
*
* THIS VERSION PROVIDES A SET OF PARAMETERS WHICH SHOULD GIVE GOOD,
* BUT NOT OPTIMAL, PERFORMANCE ON MANY OF THE CURRENTLY AVAILABLE
* COMPUTERS. USERS ARE ENCOURAGED TO MODIFY THIS SUBROUTINE TO SET
* THE TUNING PARAMETERS FOR THEIR PARTICULAR MACHINE USING THE OPTION
* AND PROBLEM SIZE INFORMATION IN THE ARGUMENTS.
*
* THIS ROUTINE WILL NOT FUNCTION CORRECTLY IF IT IS CONVERTED TO ALL
* LOWER CASE. CONVERTING IT TO ALL UPPER CASE IS ALLOWED.
*
* ARGUMENTS
* =========
*
* ISPEC (INPUT) INTEGER
* SPECIFIES THE PARAMETER TO BE RETURNED AS THE VALUE OF
* ILAENV.
* = 1: THE OPTIMAL BLOCKSIZE; IF THIS VALUE IS 1, AN UNBLOCKED
* ALGORITHM WILL GIVE THE BEST PERFORMANCE.
* = 2: THE MINIMUM BLOCK SIZE FOR WHICH THE BLOCK ROUTINE
* SHOULD BE USED; IF THE USABLE BLOCK SIZE IS LESS THAN
* THIS VALUE, AN UNBLOCKED ROUTINE SHOULD BE USED.
* = 3: THE CROSSOVER POINT (IN A BLOCK ROUTINE, FOR N LESS
* THAN THIS VALUE, AN UNBLOCKED ROUTINE SHOULD BE USED)
* = 4: THE NUMBER OF SHIFTS, USED IN THE NONSYMMETRIC
* EIGENVALUE ROUTINES
* = 5: THE MINIMUM COLUMN DIMENSION FOR BLOCKING TO BE USED;
* RECTANGULAR BLOCKS MUST HAVE DIMENSION AT LEAST K BY M,
* WHERE K IS GIVEN BY ILAENV(2,...) AND M BY ILAENV(5,...)
* = 6: THE CROSSOVER POINT FOR THE SVD (WHEN REDUCING AN M BY N
* MATRIX TO BIDIAGONAL FORM, IF MAX(M,N)/MIN(M,N) EXCEEDS
* THIS VALUE, A QR FACTORIZATION IS USED FIRST TO REDUCE
* THE MATRIX TO A TRIANGULAR FORM.)
* = 7: THE NUMBER OF PROCESSORS
* = 8: THE CROSSOVER POINT FOR THE MULTISHIFT QR AND QZ METHODS
* FOR NONSYMMETRIC EIGENVALUE PROBLEMS.
*
* NAME (INPUT) CHARACTER*(*)
* THE NAME OF THE CALLING SUBROUTINE, IN EITHER UPPER CASE OR
* LOWER CASE.
*
* OPTS (INPUT) CHARACTER*(*)
* THE CHARACTER OPTIONS TO THE SUBROUTINE NAME, CONCATENATED
* INTO A SINGLE CHARACTER STRING. FOR EXAMPLE, UPLO = 'U',
* TRANS = 'T', AND DIAG = 'N' FOR A TRIANGULAR ROUTINE WOULD
* BE SPECIFIED AS OPTS = 'UTN'.
*
* N1 (INPUT) INTEGER
* N2 (INPUT) INTEGER
* N3 (INPUT) INTEGER
* N4 (INPUT) INTEGER
* PROBLEM DIMENSIONS FOR THE SUBROUTINE NAME; THESE MAY NOT ALL
* BE REQUIRED.
*
* (ILAENV) (OUTPUT) INTEGER
* >= 0: THE VALUE OF THE PARAMETER SPECIFIED BY ISPEC
* < 0: IF ILAENV = -K, THE K-TH ARGUMENT HAD AN ILLEGAL VALUE.
*
* FURTHER DETAILS
* ===============
*
* THE FOLLOWING CONVENTIONS HAVE BEEN USED WHEN CALLING ILAENV FROM THE
* LAPACK ROUTINES:
* 1) OPTS IS A CONCATENATION OF ALL OF THE CHARACTER OPTIONS TO
* SUBROUTINE NAME, IN THE SAME ORDER THAT THEY APPEAR IN THE
* ARGUMENT LIST FOR NAME, EVEN IF THEY ARE NOT USED IN DETERMINING
* THE VALUE OF THE PARAMETER SPECIFIED BY ISPEC.
* 2) THE PROBLEM DIMENSIONS N1, N2, N3, N4 ARE SPECIFIED IN THE ORDER
* THAT THEY APPEAR IN THE ARGUMENT LIST FOR NAME. N1 IS USED
* FIRST, N2 SECOND, AND SO ON, AND UNUSED PROBLEM DIMENSIONS ARE
* PASSED A VALUE OF -1.
* 3) THE PARAMETER VALUE RETURNED BY ILAENV IS CHECKED FOR VALIDITY IN
* THE CALLING SUBROUTINE. FOR EXAMPLE, ILAENV IS USED TO RETRIEVE
* THE OPTIMAL BLOCKSIZE FOR STRTRI AS FOLLOWS:
*
* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
* IF( NB.LE.1 ) NB = MAX( 1, N )
*
* =====================================================================
*
* .. LOCAL SCALARS ..
LOGICAL CNAME, SNAME
CHARACTER*1 C1
CHARACTER*2 C2, C4
CHARACTER*3 C3
CHARACTER*6 SUBNAM
INTEGER I, IC, IZ, NB, NBMIN, NX
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC CHAR, ICHAR, INT, MIN, REAL
* ..
* .. EXECUTABLE STATEMENTS ..
*
GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC
*
* INVALID VALUE FOR ISPEC
*
ILAENV = -1
RETURN
*
100 CONTINUE
*
* CONVERT NAME TO UPPER CASE IF THE FIRST CHARACTER IS LOWER CASE.
*
ILAENV = 1
SUBNAM = NAME
IC = ICHAR( SUBNAM( 1:1 ) )
IZ = ICHAR( 'Z' )
IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
*
* ASCII CHARACTER SET
*
IF( IC.GE.97 .AND. IC.LE.122 ) THEN
SUBNAM( 1:1 ) = CHAR( IC-32 )
DO 10 I = 2, 6
IC = ICHAR( SUBNAM( I:I ) )
IF( IC.GE.97 .AND. IC.LE.122 )
$ SUBNAM( I:I ) = CHAR( IC-32 )
10 CONTINUE
END IF
*
ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
*
* EBCDIC CHARACTER SET
*
IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
$ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
$ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
SUBNAM( 1:1 ) = CHAR( IC+64 )
DO 20 I = 2, 6
IC = ICHAR( SUBNAM( I:I ) )
IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
$ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
$ ( IC.GE.162 .AND. IC.LE.169 ) )
$ SUBNAM( I:I ) = CHAR( IC+64 )
20 CONTINUE
END IF
*
ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
*
* PRIME MACHINES: ASCII+128
*
IF( IC.GE.225 .AND. IC.LE.250 ) THEN
SUBNAM( 1:1 ) = CHAR( IC-32 )
DO 30 I = 2, 6
IC = ICHAR( SUBNAM( I:I ) )
IF( IC.GE.225 .AND. IC.LE.250 )
$ SUBNAM( I:I ) = CHAR( IC-32 )
30 CONTINUE
END IF
END IF
*
C1 = SUBNAM( 1:1 )
SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
IF( .NOT.( CNAME .OR. SNAME ) )
$ RETURN
C2 = SUBNAM( 2:3 )
C3 = SUBNAM( 4:6 )
C4 = C3( 2:3 )
*
GO TO ( 110, 200, 300 ) ISPEC
*
110 CONTINUE
*
* ISPEC = 1: BLOCK SIZE
*
* IN THESE EXAMPLES, SEPARATE CODE IS PROVIDED FOR SETTING NB FOR
* REAL AND COMPLEX. WE ASSUME THAT NB WILL TAKE THE SAME VALUE IN
* SINGLE OR DOUBLE PRECISION.
*
NB = 1
*
IF( C2.EQ.'GE' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
END IF
ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
$ C3.EQ.'QLF' ) THEN
IF( SNAME ) THEN
NB = 32
ELSE
NB = 32
END IF
ELSE IF( C3.EQ.'HRD' ) THEN
IF( SNAME ) THEN
NB = 32
ELSE
NB = 32
END IF
ELSE IF( C3.EQ.'BRD' ) THEN
IF( SNAME ) THEN
NB = 32
ELSE
NB = 32
END IF
ELSE IF( C3.EQ.'TRI' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
END IF
END IF
ELSE IF( C2.EQ.'PO' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
END IF
END IF
ELSE IF( C2.EQ.'SY' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
END IF
ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
NB = 1
ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
NB = 64
END IF
ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
IF( C3.EQ.'TRF' ) THEN
NB = 64
ELSE IF( C3.EQ.'TRD' ) THEN
NB = 1
ELSE IF( C3.EQ.'GST' ) THEN
NB = 64
END IF
ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
IF( C3( 1:1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
$ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
$ C4.EQ.'BR' ) THEN
NB = 32
END IF
ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
$ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
$ C4.EQ.'BR' ) THEN
NB = 32
END IF
END IF
ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
IF( C3( 1:1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
$ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
$ C4.EQ.'BR' ) THEN
NB = 32
END IF
ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
$ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
$ C4.EQ.'BR' ) THEN
NB = 32
END IF
END IF
ELSE IF( C2.EQ.'GB' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( SNAME ) THEN
IF( N4.LE.64 ) THEN
NB = 1
ELSE
NB = 32
END IF
ELSE
IF( N4.LE.64 ) THEN
NB = 1
ELSE
NB = 32
END IF
END IF
END IF
ELSE IF( C2.EQ.'PB' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( SNAME ) THEN
IF( N2.LE.64 ) THEN
NB = 1
ELSE
NB = 32
END IF
ELSE
IF( N2.LE.64 ) THEN
NB = 1
ELSE
NB = 32
END IF
END IF
END IF
ELSE IF( C2.EQ.'TR' ) THEN
IF( C3.EQ.'TRI' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
END IF
END IF
ELSE IF( C2.EQ.'LA' ) THEN
IF( C3.EQ.'UUM' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
END IF
END IF
ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
IF( C3.EQ.'EBZ' ) THEN
NB = 1
END IF
END IF
ILAENV = NB
RETURN
*
200 CONTINUE
*
* ISPEC = 2: MINIMUM BLOCK SIZE
*
NBMIN = 2
IF( C2.EQ.'GE' ) THEN
IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
$ C3.EQ.'QLF' ) THEN
IF( SNAME ) THEN
NBMIN = 2
ELSE
NBMIN = 2
END IF
ELSE IF( C3.EQ.'HRD' ) THEN
IF( SNAME ) THEN
NBMIN = 2
ELSE
NBMIN = 2
END IF
ELSE IF( C3.EQ.'BRD' ) THEN
IF( SNAME ) THEN
NBMIN = 2
ELSE
NBMIN = 2
END IF
ELSE IF( C3.EQ.'TRI' ) THEN
IF( SNAME ) THEN
NBMIN = 2
ELSE
NBMIN = 2
END IF
END IF
ELSE IF( C2.EQ.'SY' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( SNAME ) THEN
NBMIN = 2
ELSE
NBMIN = 2
END IF
ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
NBMIN = 2
END IF
ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
IF( C3.EQ.'TRD' ) THEN
NBMIN = 2
END IF
ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
IF( C3( 1:1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
$ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
$ C4.EQ.'BR' ) THEN
NBMIN = 2
END IF
ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
$ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
$ C4.EQ.'BR' ) THEN
NBMIN = 2
END IF
END IF
ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
IF( C3( 1:1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
$ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
$ C4.EQ.'BR' ) THEN
NBMIN = 2
END IF
ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
$ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
$ C4.EQ.'BR' ) THEN
NBMIN = 2
END IF
END IF
END IF
ILAENV = NBMIN
RETURN
*
300 CONTINUE
*
* ISPEC = 3: CROSSOVER POINT
*
NX = 0
IF( C2.EQ.'GE' ) THEN
IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
$ C3.EQ.'QLF' ) THEN
IF( SNAME ) THEN
NX = 128
ELSE
NX = 128
END IF
ELSE IF( C3.EQ.'HRD' ) THEN
IF( SNAME ) THEN
NX = 128
ELSE
NX = 128
END IF
ELSE IF( C3.EQ.'BRD' ) THEN
IF( SNAME ) THEN
NX = 128
ELSE
NX = 128
END IF
END IF
ELSE IF( C2.EQ.'SY' ) THEN
IF( SNAME .AND. C3.EQ.'TRD' ) THEN
NX = 1
END IF
ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
IF( C3.EQ.'TRD' ) THEN
NX = 1
END IF
ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
IF( C3( 1:1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
$ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
$ C4.EQ.'BR' ) THEN
NX = 128
END IF
END IF
ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
IF( C3( 1:1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
$ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
$ C4.EQ.'BR' ) THEN
NX = 128
END IF
END IF
END IF
ILAENV = NX
RETURN
*
400 CONTINUE
*
* ISPEC = 4: NUMBER OF SHIFTS (USED BY XHSEQR)
*
ILAENV = 6
RETURN
*
500 CONTINUE
*
* ISPEC = 5: MINIMUM COLUMN DIMENSION (NOT USED)
*
ILAENV = 2
RETURN
*
600 CONTINUE
*
* ISPEC = 6: CROSSOVER POINT FOR SVD (USED BY XGELSS AND XGESVD)
*
ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
RETURN
*
700 CONTINUE
*
* ISPEC = 7: NUMBER OF PROCESSORS (NOT USED)
*
ILAENV = 1
RETURN
*
800 CONTINUE
*
* ISPEC = 8: CROSSOVER POINT FOR MULTISHIFT (USED BY XHSEQR)
*
ILAENV = 50
RETURN
*
* END OF ILAENV
*
END
CUT HERE............
CAT > DLANSY.F <<'CUT HERE............'
DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER NORM, UPLO
INTEGER LDA, N
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* PURPOSE
* =======
*
* DLANSY RETURNS THE VALUE OF THE ONE NORM, OR THE FROBENIUS NORM, OR
* THE INFINITY NORM, OR THE ELEMENT OF LARGEST ABSOLUTE VALUE OF A
* REAL SYMMETRIC MATRIX A.
*
* DESCRIPTION
* ===========
*
* DLANSY RETURNS THE VALUE
*
* DLANSY = ( MAX(ABS(A(I,J))), NORM = 'M' OR 'M'
* (
* ( NORM1(A), NORM = '1', 'O' OR 'O'
* (
* ( NORMI(A), NORM = 'I' OR 'I'
* (
* ( NORMF(A), NORM = 'F', 'F', 'E' OR 'E'
*
* WHERE NORM1 DENOTES THE ONE NORM OF A MATRIX (MAXIMUM COLUMN SUM),
* NORMI DENOTES THE INFINITY NORM OF A MATRIX (MAXIMUM ROW SUM) AND
* NORMF DENOTES THE FROBENIUS NORM OF A MATRIX (SQUARE ROOT OF SUM OF
* SQUARES). NOTE THAT MAX(ABS(A(I,J))) IS NOT A MATRIX NORM.
*
* ARGUMENTS
* =========
*
* NORM (INPUT) CHARACTER*1
* SPECIFIES THE VALUE TO BE RETURNED IN DLANSY AS DESCRIBED
* ABOVE.
*
* UPLO (INPUT) CHARACTER*1
* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE
* SYMMETRIC MATRIX A IS TO BE REFERENCED.
* = 'U': UPPER TRIANGULAR PART OF A IS REFERENCED
* = 'L': LOWER TRIANGULAR PART OF A IS REFERENCED
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX A. N >= 0. WHEN N = 0, DLANSY IS
* SET TO ZERO.
*
* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING N BY N
* UPPER TRIANGULAR PART OF A CONTAINS THE UPPER TRIANGULAR PART
* OF THE MATRIX A, AND THE STRICTLY LOWER TRIANGULAR PART OF A
* IS NOT REFERENCED. IF UPLO = 'L', THE LEADING N BY N LOWER
* TRIANGULAR PART OF A CONTAINS THE LOWER TRIANGULAR PART OF
* THE MATRIX A, AND THE STRICTLY UPPER TRIANGULAR PART OF A IS
* NOT REFERENCED.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(N,1).
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK),
* WHERE LWORK >= N WHEN NORM = 'I' OR '1' OR 'O'; OTHERWISE,
* WORK IS NOT REFERENCED.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, J
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLASSQ
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. EXECUTABLE STATEMENTS ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* FIND MAX(ABS(A(I,J))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = J, N
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* FIND NORMI(A) ( = NORM1(A), SINCE A IS SYMMETRIC).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
50 CONTINUE
WORK( J ) = SUM + ABS( A( J, J ) )
60 CONTINUE
DO 70 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( A( J, J ) )
DO 90 I = J + 1, N
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
90 CONTINUE
VALUE = MAX( VALUE, SUM )
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* FIND NORMF(A).
*
SCALE = ZERO
SUM = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
120 CONTINUE
END IF
SUM = 2*SUM
CALL DLASSQ( N, A, LDA+1, SCALE, SUM )
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANSY = VALUE
RETURN
*
* END OF DLANSY
*
END
CUT HERE............
CAT > DLASSQ.F <<'CUT HERE............'
SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
INTEGER INCX, N
DOUBLE PRECISION SCALE, SUMSQ
* ..
* .. ARRAY ARGUMENTS ..
DOUBLE PRECISION X( * )
* ..
*
* PURPOSE
* =======
*
* DLASSQ RETURNS THE VALUES SCL AND SMSQ SUCH THAT
*
* ( SCL**2 )*SMSQ = X( 1 )**2 +...+ X( N )**2 + ( SCALE**2 )*SUMSQ,
*
* WHERE X( I ) = X( 1 + ( I - 1 )*INCX ). THE VALUE OF SUMSQ IS
* ASSUMED TO BE NON-NEGATIVE AND SCL RETURNS THE VALUE
*
* SCL = MAX( SCALE, ABS( X( I ) ) ).
*
* SCALE AND SUMSQ MUST BE SUPPLIED IN SCALE AND SUMSQ AND
* SCL AND SMSQ ARE OVERWRITTEN ON SCALE AND SUMSQ RESPECTIVELY.
*
* THE ROUTINE MAKES ONLY ONE PASS THROUGH THE VECTOR X.
*
* ARGUMENTS
* =========
*
* N (INPUT) INTEGER
* THE NUMBER OF ELEMENTS TO BE USED FROM THE VECTOR X.
*
* X (INPUT) DOUBLE PRECISION
* THE VECTOR FOR WHICH A SCALED SUM OF SQUARES IS COMPUTED.
* X( I ) = X( 1 + ( I - 1 )*INCX ), 1 <= I <= N.
*
* INCX (INPUT) INTEGER
* THE INCREMENT BETWEEN SUCCESSIVE VALUES OF THE VECTOR X.
* INCX > 0.
*
* SCALE (INPUT/OUTPUT) DOUBLE PRECISION
* ON ENTRY, THE VALUE SCALE IN THE EQUATION ABOVE.
* ON EXIT, SCALE IS OVERWRITTEN WITH SCL , THE SCALING FACTOR
* FOR THE SUM OF SQUARES.
*
* SUMSQ (INPUT/OUTPUT) DOUBLE PRECISION
* ON ENTRY, THE VALUE SUMSQ IN THE EQUATION ABOVE.
* ON EXIT, SUMSQ IS OVERWRITTEN WITH SMSQ , THE BASIC SUM OF
* SQUARES FROM WHICH SCL HAS BEEN FACTORED OUT.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER IX
DOUBLE PRECISION ABSXI
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS
* ..
* .. EXECUTABLE STATEMENTS ..
*
IF( N.GT.0 ) THEN
DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
IF( X( IX ).NE.ZERO ) THEN
ABSXI = ABS( X( IX ) )
IF( SCALE.LT.ABSXI ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
SCALE = ABSXI
ELSE
SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
END IF
END IF
10 CONTINUE
END IF
RETURN
*
* END OF DLASSQ
*
END
CUT HERE............
C ----------------- BELOW IS DSYTRF -------------------
CAT > DSYTRF.F <<'CUT HERE..........'
SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.0B) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* FEBRUARY 29, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), WORK( LWORK )
* ..
*
* PURPOSE
* =======
*
* DSYTRF COMPUTES THE FACTORIZATION OF A REAL SYMMETRIC MATRIX A USING
* THE BUNCH-KAUFMAN DIAGONAL PIVOTING METHOD:
*
* A = U*D*U' OR A = L*D*L'
*
* WHERE U (OR L) IS A PRODUCT OF PERMUTATION AND UNIT UPPER (LOWER)
* TRIANGULAR MATRICES, U' IS THE TRANSPOSE OF U, AND D IS SYMMETRIC AND
* BLOCK DIAGONAL WITH 1-BY-1 AND 2-BY-2 DIAGONAL BLOCKS.
*
* THIS IS THE BLOCKED VERSION OF THE ALGORITHM, CALLING LEVEL 3 BLAS.
*
* ARGUMENTS
* =========
*
* UPLO (INPUT) CHARACTER*1
* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE
* SYMMETRIC MATRIX A IS STORED:
* = 'U': UPPER TRIANGULAR
* = 'L': LOWER TRIANGULAR
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX A. N >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING
* N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE UPPER
* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY LOWER
* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE
* LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS THE LOWER
* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY UPPER
* TRIANGULAR PART OF A IS NOT REFERENCED.
*
* ON EXIT, THE BLOCK DIAGONAL MATRIX D AND THE MULTIPLIERS USED
* TO OBTAIN THE FACTOR U OR L (SEE BELOW FOR FURTHER DETAILS).
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N).
*
* IPIV (OUTPUT) INTEGER ARRAY, DIMENSION (N)
* DETAILS OF THE INTERCHANGES AND THE BLOCK STRUCTURE OF D.
* IF IPIV(K) > 0, THEN ROWS AND COLUMNS K AND IPIV(K) WERE
* INTERCHANGED AND D(K,K) IS A 1-BY-1 DIAGONAL BLOCK.
* IF UPLO = 'U' AND IPIV(K) = IPIV(K-1) < 0, THEN ROWS AND
* COLUMNS K-1 AND -IPIV(K) WERE INTERCHANGED AND D(K-1:K,K-1:K)
* IS A 2-BY-2 DIAGONAL BLOCK. IF UPLO = 'L' AND IPIV(K) =
* IPIV(K+1) < 0, THEN ROWS AND COLUMNS K+1 AND -IPIV(K) WERE
* INTERCHANGED AND D(K:K+1,K:K+1) IS A 2-BY-2 DIAGONAL BLOCK.
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK)
* IF INFO RETURNS 0, THEN WORK(1) RETURNS N*NB, THE MINIMUM
* VALUE OF LWORK REQUIRED TO USE THE OPTIMAL BLOCKSIZE.
*
* LWORK (INPUT) INTEGER
* THE LENGTH OF WORK. LWORK SHOULD BE >= N*NB, WHERE NB IS THE
* BLOCK SIZE RETURNED BY ILAENV.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -K, THE K-TH ARGUMENT HAD AN ILLEGAL VALUE
* > 0: IF INFO = K, D(K,K) IS EXACTLY ZERO. THE FACTORIZATION
* HAS BEEN COMPLETED, BUT THE BLOCK DIAGONAL MATRIX D IS
* EXACTLY SINGULAR, AND DIVISION BY ZERO WILL OCCUR IF IT
* IS USED TO SOLVE A SYSTEM OF EQUATIONS.
*
* FURTHER DETAILS
* ===============
*
* IF UPLO = 'U', THEN A = U*D*U', WHERE
* U = P(N)*U(N)* ... *P(K)U(K)* ...,
* I.E., U IS A PRODUCT OF TERMS P(K)*U(K), WHERE K DECREASES FROM N TO
* 1 IN STEPS OF 1 OR 2, AND D IS A BLOCK DIAGONAL MATRIX WITH 1-BY-1
* AND 2-BY-2 DIAGONAL BLOCKS D(K). P(K) IS A PERMUTATION MATRIX AS
* DEFINED BY IPIV(K), AND U(K) IS A UNIT UPPER TRIANGULAR MATRIX, SUCH
* THAT IF THE DIAGONAL BLOCK D(K) IS OF ORDER S (S = 1 OR 2), THEN
*
* ( I V 0 ) K-S
* U(K) = ( 0 I 0 ) S
* ( 0 0 I ) N-K
* K-S S N-K
*
* IF S = 1, D(K) OVERWRITES A(K,K), AND V OVERWRITES A(1:K-1,K).
* IF S = 2, THE UPPER TRIANGLE OF D(K) OVERWRITES A(K-1,K-1), A(K-1,K),
* AND A(K,K), AND V OVERWRITES A(1:K-2,K-1:K).
*
* IF UPLO = 'L', THEN A = L*D*L', WHERE
* L = P(1)*L(1)* ... *P(K)*L(K)* ...,
* I.E., L IS A PRODUCT OF TERMS P(K)*L(K), WHERE K INCREASES FROM 1 TO
* N IN STEPS OF 1 OR 2, AND D IS A BLOCK DIAGONAL MATRIX WITH 1-BY-1
* AND 2-BY-2 DIAGONAL BLOCKS D(K). P(K) IS A PERMUTATION MATRIX AS
* DEFINED BY IPIV(K), AND L(K) IS A UNIT LOWER TRIANGULAR MATRIX, SUCH
* THAT IF THE DIAGONAL BLOCK D(K) IS OF ORDER S (S = 1 OR 2), THEN
*
* ( I 0 0 ) K-1
* L(K) = ( 0 I 0 ) S
* ( 0 V I ) N-K-S+1
* K-1 S N-K-S+1
*
* IF S = 1, D(K) OVERWRITES A(K,K), AND V OVERWRITES A(K+1:N,K).
* IF S = 2, THE LOWER TRIANGLE OF D(K) OVERWRITES A(K,K), A(K+1,K),
* AND A(K+1,K+1), AND V OVERWRITES A(K+2:N,K:K+1).
*
* =====================================================================
*
* .. LOCAL SCALARS ..
LOGICAL UPPER
INTEGER IINFO, IWS, J, K, KB, LDWORK, NB, NBMIN
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLASYF, DSYTF2, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTRF', -INFO )
RETURN
END IF
*
* DETERMINE THE BLOCK SIZE
*
NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) )
END IF
ELSE
IWS = 1
END IF
IF( NB.LT.NBMIN )
$ NB = N
*
IF( UPPER ) THEN
*
* FACTORIZE A AS U*D*U' USING THE UPPER TRIANGLE OF A
*
* K IS THE MAIN LOOP INDEX, DECREASING FROM N TO 1 IN STEPS OF
* KB, WHERE KB IS THE NUMBER OF COLUMNS FACTORIZED BY DLASYF;
* KB IS EITHER NB OR NB-1, OR K FOR THE LAST BLOCK
*
K = N
10 CONTINUE
*
* IF K < 1, EXIT FROM LOOP
*
IF( K.LT.1 )
$ GO TO 40
*
IF( K.GT.NB ) THEN
*
* FACTORIZE COLUMNS K-KB+1:K OF A AND USE BLOCKED CODE TO
* UPDATE COLUMNS 1:K-KB
*
CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK,
$ IINFO )
ELSE
*
* USE UNBLOCKED CODE TO FACTORIZE COLUMNS 1:K OF A
*
CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO )
KB = K
END IF
*
* SET INFO ON THE FIRST OCCURRENCE OF A ZERO PIVOT
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO
*
* DECREASE K AND RETURN TO THE START OF THE MAIN LOOP
*
K = K - KB
GO TO 10
*
ELSE
*
* FACTORIZE A AS L*D*L' USING THE LOWER TRIANGLE OF A
*
* K IS THE MAIN LOOP INDEX, INCREASING FROM 1 TO N IN STEPS OF
* KB, WHERE KB IS THE NUMBER OF COLUMNS FACTORIZED BY DLASYF;
* KB IS EITHER NB OR NB-1, OR N-K+1 FOR THE LAST BLOCK
*
K = 1
20 CONTINUE
*
* IF K > N, EXIT FROM LOOP
*
IF( K.GT.N )
$ GO TO 40
*
IF( K.LE.N-NB ) THEN
*
* FACTORIZE COLUMNS K:K+KB-1 OF A AND USE BLOCKED CODE TO
* UPDATE COLUMNS K+KB:N
*
CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ),
$ WORK, LDWORK, IINFO )
ELSE
*
* USE UNBLOCKED CODE TO FACTORIZE COLUMNS K:N OF A
*
CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO )
KB = N - K + 1
END IF
*
* SET INFO ON THE FIRST OCCURRENCE OF A ZERO PIVOT
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + K - 1
*
* ADJUST IPIV
*
DO 30 J = K, K + KB - 1
IF( IPIV( J ).GT.0 ) THEN
IPIV( J ) = IPIV( J ) + K - 1
ELSE
IPIV( J ) = IPIV( J ) - K + 1
END IF
30 CONTINUE
*
* INCREASE K AND RETURN TO THE START OF THE MAIN LOOP
*
K = K + KB
GO TO 20
*
END IF
*
40 CONTINUE
WORK( 1 ) = IWS
RETURN
*
* END OF DSYTRF
*
END
CUT HERE..........
CAT > DSYTF2.F <<'CUT HERE..........'
SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.0B) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * )
* ..
*
* PURPOSE
* =======
*
* DSYTF2 COMPUTES THE FACTORIZATION OF A REAL SYMMETRIC MATRIX A USING
* THE BUNCH-KAUFMAN DIAGONAL PIVOTING METHOD:
*
* A = U*D*U' OR A = L*D*L'
*
* WHERE U (OR L) IS A PRODUCT OF PERMUTATION AND UNIT UPPER (LOWER)
* TRIANGULAR MATRICES, U' IS THE TRANSPOSE OF U, AND D IS SYMMETRIC AND
* BLOCK DIAGONAL WITH 1-BY-1 AND 2-BY-2 DIAGONAL BLOCKS.
*
* THIS IS THE UNBLOCKED VERSION OF THE ALGORITHM, CALLING LEVEL 2 BLAS.
*
* ARGUMENTS
* =========
*
* UPLO (INPUT) CHARACTER*1
* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE
* SYMMETRIC MATRIX A IS STORED:
* = 'U': UPPER TRIANGULAR
* = 'L': LOWER TRIANGULAR
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX A. N >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING
* N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE UPPER
* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY LOWER
* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE
* LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS THE LOWER
* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY UPPER
* TRIANGULAR PART OF A IS NOT REFERENCED.
*
* ON EXIT, THE BLOCK DIAGONAL MATRIX D AND THE MULTIPLIERS USED
* TO OBTAIN THE FACTOR U OR L (SEE BELOW FOR FURTHER DETAILS).
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N).
*
* IPIV (OUTPUT) INTEGER ARRAY, DIMENSION (N)
* DETAILS OF THE INTERCHANGES AND THE BLOCK STRUCTURE OF D.
* IF IPIV(K) > 0, THEN ROWS AND COLUMNS K AND IPIV(K) WERE
* INTERCHANGED AND D(K,K) IS A 1-BY-1 DIAGONAL BLOCK.
* IF UPLO = 'U' AND IPIV(K) = IPIV(K-1) < 0, THEN ROWS AND
* COLUMNS K-1 AND -IPIV(K) WERE INTERCHANGED AND D(K-1:K,K-1:K)
* IS A 2-BY-2 DIAGONAL BLOCK. IF UPLO = 'L' AND IPIV(K) =
* IPIV(K+1) < 0, THEN ROWS AND COLUMNS K+1 AND -IPIV(K) WERE
* INTERCHANGED AND D(K:K+1,K:K+1) IS A 2-BY-2 DIAGONAL BLOCK.
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -K, THE K-TH ARGUMENT HAD AN ILLEGAL VALUE
* > 0: IF INFO = K, D(K,K) IS EXACTLY ZERO. THE FACTORIZATION
* HAS BEEN COMPLETED, BUT THE BLOCK DIAGONAL MATRIX D IS
* EXACTLY SINGULAR, AND DIVISION BY ZERO WILL OCCUR IF IT
* IS USED TO SOLVE A SYSTEM OF EQUATIONS.
*
* FURTHER DETAILS
* ===============
*
* IF UPLO = 'U', THEN A = U*D*U', WHERE
* U = P(N)*U(N)* ... *P(K)U(K)* ...,
* I.E., U IS A PRODUCT OF TERMS P(K)*U(K), WHERE K DECREASES FROM N TO
* 1 IN STEPS OF 1 OR 2, AND D IS A BLOCK DIAGONAL MATRIX WITH 1-BY-1
* AND 2-BY-2 DIAGONAL BLOCKS D(K). P(K) IS A PERMUTATION MATRIX AS
* DEFINED BY IPIV(K), AND U(K) IS A UNIT UPPER TRIANGULAR MATRIX, SUCH
* THAT IF THE DIAGONAL BLOCK D(K) IS OF ORDER S (S = 1 OR 2), THEN
*
* ( I V 0 ) K-S
* U(K) = ( 0 I 0 ) S
* ( 0 0 I ) N-K
* K-S S N-K
*
* IF S = 1, D(K) OVERWRITES A(K,K), AND V OVERWRITES A(1:K-1,K).
* IF S = 2, THE UPPER TRIANGLE OF D(K) OVERWRITES A(K-1,K-1), A(K-1,K),
* AND A(K,K), AND V OVERWRITES A(1:K-2,K-1:K).
*
* IF UPLO = 'L', THEN A = L*D*L', WHERE
* L = P(1)*L(1)* ... *P(K)*L(K)* ...,
* I.E., L IS A PRODUCT OF TERMS P(K)*L(K), WHERE K INCREASES FROM 1 TO
* N IN STEPS OF 1 OR 2, AND D IS A BLOCK DIAGONAL MATRIX WITH 1-BY-1
* AND 2-BY-2 DIAGONAL BLOCKS D(K). P(K) IS A PERMUTATION MATRIX AS
* DEFINED BY IPIV(K), AND L(K) IS A UNIT LOWER TRIANGULAR MATRIX, SUCH
* THAT IF THE DIAGONAL BLOCK D(K) IS OF ORDER S (S = 1 OR 2), THEN
*
* ( I 0 0 ) K-1
* L(K) = ( 0 I 0 ) S
* ( 0 V I ) N-K-S+1
* K-1 S N-K-S+1
*
* IF S = 1, D(K) OVERWRITES A(K,K), AND V OVERWRITES A(K+1:N,K).
* IF S = 2, THE LOWER TRIANGLE OF D(K) OVERWRITES A(K,K), A(K+1,K),
* AND A(K+1,K+1), AND V OVERWRITES A(K+2:N,K:K+1).
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
* ..
* .. LOCAL SCALARS ..
LOGICAL UPPER
INTEGER IMAX, JMAX, K, KK, KP, KSTEP
DOUBLE PRECISION ABSAKK, ALPHA, C, COLMAX, R1, R2, ROWMAX, S, T
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
INTEGER IDAMAX
EXTERNAL LSAME, IDAMAX
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLAEV2, DROT, DSCAL, DSWAP, DSYR, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTF2', -INFO )
RETURN
END IF
*
* INITIALIZE ALPHA FOR USE IN CHOOSING PIVOT BLOCK SIZE.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( UPPER ) THEN
*
* FACTORIZE A AS U*D*U' USING THE UPPER TRIANGLE OF A
*
* K IS THE MAIN LOOP INDEX, DECREASING FROM N TO 1 IN STEPS OF
* 1 OR 2
*
K = N
10 CONTINUE
*
* IF K < 1, EXIT FROM LOOP
*
IF( K.LT.1 )
$ GO TO 30
KSTEP = 1
*
* DETERMINE ROWS AND COLUMNS TO BE INTERCHANGED AND WHETHER
* A 1-BY-1 OR 2-BY-2 PIVOT BLOCK WILL BE USED
*
ABSAKK = ABS( A( K, K ) )
*
* IMAX IS THE ROW-INDEX OF THE LARGEST OFF-DIAGONAL ELEMENT IN
* COLUMN K, AND COLMAX IS ITS ABSOLUTE VALUE
*
IF( K.GT.1 ) THEN
IMAX = IDAMAX( K-1, A( 1, K ), 1 )
COLMAX = ABS( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* COLUMN K IS ZERO: SET INFO AND CONTINUE
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK
*
KP = K
ELSE
*
* JMAX IS THE COLUMN-INDEX OF THE LARGEST OFF-DIAGONAL
* ELEMENT IN ROW IMAX, AND ROWMAX IS ITS ABSOLUTE VALUE
*
JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
ROWMAX = ABS( A( IMAX, JMAX ) )
IF( IMAX.GT.1 ) THEN
JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 )
ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK
*
KP = K
ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
*
* INTERCHANGE ROWS AND COLUMNS K AND IMAX, USE 1-BY-1
* PIVOT BLOCK
*
KP = IMAX
ELSE
*
* INTERCHANGE ROWS AND COLUMNS K-1 AND IMAX, USE 2-BY-2
* PIVOT BLOCK
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K - KSTEP + 1
IF( KP.NE.KK ) THEN
*
* INTERCHANGE ROWS AND COLUMNS KK AND KP IN THE LEADING
* SUBMATRIX A(1:K,1:K)
*
CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
T = A( KK, KK )
A( KK, KK ) = A( KP, KP )
A( KP, KP ) = T
IF( KSTEP.EQ.2 ) THEN
T = A( K-1, K )
A( K-1, K ) = A( KP, K )
A( KP, K ) = T
END IF
END IF
*
* UPDATE THE LEADING SUBMATRIX
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-BY-1 PIVOT BLOCK D(K): COLUMN K NOW HOLDS
*
* W(K) = U(K)*D(K)
*
* WHERE U(K) IS THE K-TH COLUMN OF U
*
* PERFORM A RANK-1 UPDATE OF A(1:K-1,1:K-1) AS
*
* A := A - U(K)*D(K)*U(K)' = A - W(K)*1/D(K)*W(K)'
*
R1 = ONE / A( K, K )
CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
*
* STORE U(K) IN COLUMN K
*
CALL DSCAL( K-1, R1, A( 1, K ), 1 )
ELSE
*
* 2-BY-2 PIVOT BLOCK D(K): COLUMNS K AND K-1 NOW HOLD
*
* ( W(K-1) W(K) ) = ( U(K-1) U(K) )*D(K)
*
* WHERE U(K) AND U(K-1) ARE THE K-TH AND (K-1)-TH COLUMNS
* OF U
*
* PERFORM A RANK-2 UPDATE OF A(1:K-2,1:K-2) AS
*
* A := A - ( U(K-1) U(K) )*D(K)*( U(K-1) U(K) )'
* = A - ( W(K-1) W(K) )*INV(D(K))*( W(K-1) W(K) )'
*
* CONVERT THIS TO TWO RANK-1 UPDATES BY USING THE EIGEN-
* DECOMPOSITION OF D(K)
*
CALL DLAEV2( A( K-1, K-1 ), A( K-1, K ), A( K, K ), R1,
$ R2, C, S )
R1 = ONE / R1
R2 = ONE / R2
CALL DROT( K-2, A( 1, K-1 ), 1, A( 1, K ), 1, C, S )
CALL DSYR( UPLO, K-2, -R1, A( 1, K-1 ), 1, A, LDA )
CALL DSYR( UPLO, K-2, -R2, A( 1, K ), 1, A, LDA )
*
* STORE U(K) AND U(K-1) IN COLUMNS K AND K-1
*
CALL DSCAL( K-2, R1, A( 1, K-1 ), 1 )
CALL DSCAL( K-2, R2, A( 1, K ), 1 )
CALL DROT( K-2, A( 1, K-1 ), 1, A( 1, K ), 1, C, -S )
END IF
END IF
*
* STORE DETAILS OF THE INTERCHANGES IN IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* DECREASE K AND RETURN TO THE START OF THE MAIN LOOP
*
K = K - KSTEP
GO TO 10
*
ELSE
*
* FACTORIZE A AS L*D*L' USING THE LOWER TRIANGLE OF A
*
* K IS THE MAIN LOOP INDEX, INCREASING FROM 1 TO N IN STEPS OF
* 1 OR 2
*
K = 1
20 CONTINUE
*
* IF K > N, EXIT FROM LOOP
*
IF( K.GT.N )
$ GO TO 30
KSTEP = 1
*
* DETERMINE ROWS AND COLUMNS TO BE INTERCHANGED AND WHETHER
* A 1-BY-1 OR 2-BY-2 PIVOT BLOCK WILL BE USED
*
ABSAKK = ABS( A( K, K ) )
*
* IMAX IS THE ROW-INDEX OF THE LARGEST OFF-DIAGONAL ELEMENT IN
* COLUMN K, AND COLMAX IS ITS ABSOLUTE VALUE
*
IF( K.LT.N ) THEN
IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 )
COLMAX = ABS( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* COLUMN K IS ZERO: SET INFO AND CONTINUE
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK
*
KP = K
ELSE
*
* JMAX IS THE COLUMN-INDEX OF THE LARGEST OFF-DIAGONAL
* ELEMENT IN ROW IMAX, AND ROWMAX IS ITS ABSOLUTE VALUE
*
JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA )
ROWMAX = ABS( A( IMAX, JMAX ) )
IF( IMAX.LT.N ) THEN
JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK
*
KP = K
ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
*
* INTERCHANGE ROWS AND COLUMNS K AND IMAX, USE 1-BY-1
* PIVOT BLOCK
*
KP = IMAX
ELSE
*
* INTERCHANGE ROWS AND COLUMNS K+1 AND IMAX, USE 2-BY-2
* PIVOT BLOCK
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K + KSTEP - 1
IF( KP.NE.KK ) THEN
*
* INTERCHANGE ROWS AND COLUMNS KK AND KP IN THE TRAILING
* SUBMATRIX A(K:N,K:N)
*
IF( KP.LT.N )
$ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
$ LDA )
T = A( KK, KK )
A( KK, KK ) = A( KP, KP )
A( KP, KP ) = T
IF( KSTEP.EQ.2 ) THEN
T = A( K+1, K )
A( K+1, K ) = A( KP, K )
A( KP, K ) = T
END IF
END IF
*
* UPDATE THE TRAILING SUBMATRIX
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-BY-1 PIVOT BLOCK D(K): COLUMN K NOW HOLDS
*
* W(K) = L(K)*D(K)
*
* WHERE L(K) IS THE K-TH COLUMN OF L
*
IF( K.LT.N ) THEN
*
* PERFORM A RANK-1 UPDATE OF A(K+1:N,K+1:N) AS
*
* A := A - L(K)*D(K)*L(K)' = A - W(K)*(1/D(K))*W(K)'
*
R1 = ONE / A( K, K )
CALL DSYR( UPLO, N-K, -R1, A( K+1, K ), 1,
$ A( K+1, K+1 ), LDA )
*
* STORE L(K) IN COLUMN K
*
CALL DSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
ELSE
*
* 2-BY-2 PIVOT BLOCK D(K): COLUMNS K AND K+1 NOW HOLD
*
* ( W(K) W(K+1) ) = ( L(K) L(K+1) )*D(K)
*
* WHERE L(K) AND L(K+1) ARE THE K-TH AND (K+1)-TH COLUMNS
* OF L
*
IF( K.LT.N-1 ) THEN
*
* PERFORM A RANK-2 UPDATE OF A(K+2:N,K+2:N) AS
*
* A := A - ( L(K) L(K+1) )*D(K)*( L(K) L(K+1) )'
* = A - ( W(K) W(K+1) )*INV(D(K))*( W(K) W(K+1) )'
*
* CONVERT THIS TO TWO RANK-1 UPDATES BY USING THE EIGEN-
* DECOMPOSITION OF D(K)
*
CALL DLAEV2( A( K, K ), A( K+1, K ), A( K+1, K+1 ),
$ R1, R2, C, S )
R1 = ONE / R1
R2 = ONE / R2
CALL DROT( N-K-1, A( K+2, K ), 1, A( K+2, K+1 ), 1, C,
$ S )
CALL DSYR( UPLO, N-K-1, -R1, A( K+2, K ), 1,
$ A( K+2, K+2 ), LDA )
CALL DSYR( UPLO, N-K-1, -R2, A( K+2, K+1 ), 1,
$ A( K+2, K+2 ), LDA )
*
* STORE L(K) AND L(K+1) IN COLUMNS K AND K+1
*
CALL DSCAL( N-K-1, R1, A( K+2, K ), 1 )
CALL DSCAL( N-K-1, R2, A( K+2, K+1 ), 1 )
CALL DROT( N-K-1, A( K+2, K ), 1, A( K+2, K+1 ), 1, C,
$ -S )
END IF
END IF
END IF
*
* STORE DETAILS OF THE INTERCHANGES IN IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* INCREASE K AND RETURN TO THE START OF THE MAIN LOOP
*
K = K + KSTEP
GO TO 20
*
END IF
*
30 CONTINUE
RETURN
*
* END OF DSYTF2
*
END
CUT HERE..........
CAT > DLASYF.F <<'CUT HERE..........'
SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.0B) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* FEBRUARY 29, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER UPLO
INTEGER INFO, KB, LDA, LDW, N, NB
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), W( LDW, * )
* ..
*
* PURPOSE
* =======
*
* DLASYF COMPUTES A PARTIAL FACTORIZATION OF A REAL SYMMETRIC MATRIX A
* USING THE BUNCH-KAUFMAN DIAGONAL PIVOTING METHOD. THE PARTIAL
* FACTORIZATION HAS THE FORM:
*
* A = ( I U12 ) ( A11 0 ) ( I 0 ) IF UPLO = 'U', OR:
* ( 0 U22 ) ( 0 D ) ( U12' U22' )
*
* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) IF UPLO = 'L'
* ( L21 I ) ( 0 A22 ) ( 0 I )
*
* WHERE THE ORDER OF D IS AT MOST NB. THE ACTUAL ORDER IS RETURNED IN
* THE ARGUMENT KB, AND IS EITHER NB OR NB-1, OR N IF N <= NB.
*
* DLASYF IS AN AUXILIARY ROUTINE CALLED BY DSYTRF. IT USES BLOCKED CODE
* (CALLING LEVEL 3 BLAS) TO UPDATE THE SUBMATRIX A11 (IF UPLO = 'U') OR
* A22 (IF UPLO = 'L').
*
* ARGUMENTS
* =========
*
* UPLO (INPUT) CHARACTER*1
* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE
* SYMMETRIC MATRIX A IS STORED:
* = 'U': UPPER TRIANGULAR
* = 'L': LOWER TRIANGULAR
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX A. N >= 0.
*
* NB (INPUT) INTEGER
* THE MAXIMUM NUMBER OF COLUMNS OF THE MATRIX A THAT SHOULD BE
* FACTORED. NB SHOULD BE AT LEAST 2 TO ALLOW FOR 2-BY-2 PIVOT
* BLOCKS.
*
* KB (OUTPUT) INTEGER
* THE NUMBER OF COLUMNS OF A THAT WERE ACTUALLY FACTORED.
* KB IS EITHER NB-1 OR NB, OR N IF N <= NB.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING
* N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE UPPER
* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY LOWER
* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE
* LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS THE LOWER
* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY UPPER
* TRIANGULAR PART OF A IS NOT REFERENCED.
* ON EXIT, A CONTAINS DETAILS OF THE PARTIAL FACTORIZATION.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N).
*
* IPIV (OUTPUT) INTEGER ARRAY, DIMENSION (N)
* DETAILS OF THE INTERCHANGES AND THE BLOCK STRUCTURE OF D.
* IF UPLO = 'U', ONLY THE LAST KB ELEMENTS OF IPIV ARE SET;
* IF UPLO = 'L', ONLY THE FIRST KB ELEMENTS ARE SET.
*
* IF IPIV(K) > 0, THEN ROWS AND COLUMNS K AND IPIV(K) WERE
* INTERCHANGED AND D(K,K) IS A 1-BY-1 DIAGONAL BLOCK.
* IF UPLO = 'U' AND IPIV(K) = IPIV(K-1) < 0, THEN ROWS AND
* COLUMNS K-1 AND -IPIV(K) WERE INTERCHANGED AND D(K-1:K,K-1:K)
* IS A 2-BY-2 DIAGONAL BLOCK. IF UPLO = 'L' AND IPIV(K) =
* IPIV(K+1) < 0, THEN ROWS AND COLUMNS K+1 AND -IPIV(K) WERE
* INTERCHANGED AND D(K:K+1,K:K+1) IS A 2-BY-2 DIAGONAL BLOCK.
*
* W (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LDW,NB)
*
* LDW (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY W. LDW >= MAX(1,N).
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* > 0: IF INFO = K, D(K,K) IS EXACTLY ZERO. THE FACTORIZATION
* HAS BEEN COMPLETED, BUT THE BLOCK DIAGONAL MATRIX D IS
* EXACTLY SINGULAR.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
$ KSTEP, KW
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1,
$ ROWMAX, T
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
INTEGER IDAMAX
EXTERNAL LSAME, IDAMAX
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. EXECUTABLE STATEMENTS ..
*
INFO = 0
*
* INITIALIZE ALPHA FOR USE IN CHOOSING PIVOT BLOCK SIZE.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* FACTORIZE THE TRAILING COLUMNS OF A USING THE UPPER TRIANGLE
* OF A AND WORKING BACKWARDS, AND COMPUTE THE MATRIX W = U12*D
* FOR USE IN UPDATING A11
*
* K IS THE MAIN LOOP INDEX, DECREASING FROM N IN STEPS OF 1 OR 2
*
* KW IS THE COLUMN OF W WHICH CORRESPONDS TO COLUMN K OF A
*
K = N
10 CONTINUE
KW = NB + K - N
*
* EXIT FROM LOOP
*
IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
$ GO TO 30
*
* COPY COLUMN K OF A TO COLUMN KW OF W AND UPDATE IT
*
CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
IF( K.LT.N )
$ CALL DGEMV( 'NO TRANSPOSE', K, N-K, -ONE, A( 1, K+1 ), LDA,
$ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
*
KSTEP = 1
*
* DETERMINE ROWS AND COLUMNS TO BE INTERCHANGED AND WHETHER
* A 1-BY-1 OR 2-BY-2 PIVOT BLOCK WILL BE USED
*
ABSAKK = ABS( W( K, KW ) )
*
* IMAX IS THE ROW-INDEX OF THE LARGEST OFF-DIAGONAL ELEMENT IN
* COLUMN K, AND COLMAX IS ITS ABSOLUTE VALUE
*
IF( K.GT.1 ) THEN
IMAX = IDAMAX( K-1, W( 1, KW ), 1 )
COLMAX = ABS( W( IMAX, KW ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* COLUMN K IS ZERO: SET INFO AND CONTINUE
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK
*
KP = K
ELSE
*
* COPY COLUMN IMAX TO COLUMN KW-1 OF W AND UPDATE IT
*
CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
$ W( IMAX+1, KW-1 ), 1 )
IF( K.LT.N )
$ CALL DGEMV( 'NO TRANSPOSE', K, N-K, -ONE, A( 1, K+1 ),
$ LDA, W( IMAX, KW+1 ), LDW, ONE,
$ W( 1, KW-1 ), 1 )
*
* JMAX IS THE COLUMN-INDEX OF THE LARGEST OFF-DIAGONAL
* ELEMENT IN ROW IMAX, AND ROWMAX IS ITS ABSOLUTE VALUE
*
JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
ROWMAX = ABS( W( JMAX, KW-1 ) )
IF( IMAX.GT.1 ) THEN
JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 )
ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK
*
KP = K
ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN
*
* INTERCHANGE ROWS AND COLUMNS K AND IMAX, USE 1-BY-1
* PIVOT BLOCK
*
KP = IMAX
*
* COPY COLUMN KW-1 OF W TO COLUMN KW
*
CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
ELSE
*
* INTERCHANGE ROWS AND COLUMNS K-1 AND IMAX, USE 2-BY-2
* PIVOT BLOCK
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K - KSTEP + 1
KKW = NB + KK - N
*
* UPDATED COLUMN KP IS ALREADY STORED IN COLUMN KKW OF W
*
IF( KP.NE.KK ) THEN
*
* COPY NON-UPDATED COLUMN KK TO COLUMN KP
*
A( KP, K ) = A( KK, K )
CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
*
* INTERCHANGE ROWS KK AND KP IN LAST KK COLUMNS OF A AND W
*
CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-BY-1 PIVOT BLOCK D(K): COLUMN KW OF W NOW HOLDS
*
* W(K) = U(K)*D(K)
*
* WHERE U(K) IS THE K-TH COLUMN OF U
*
* STORE U(K) IN COLUMN K OF A
*
CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
R1 = ONE / A( K, K )
CALL DSCAL( K-1, R1, A( 1, K ), 1 )
ELSE
*
* 2-BY-2 PIVOT BLOCK D(K): COLUMNS KW AND KW-1 OF W NOW
* HOLD
*
* ( W(K-1) W(K) ) = ( U(K-1) U(K) )*D(K)
*
* WHERE U(K) AND U(K-1) ARE THE K-TH AND (K-1)-TH COLUMNS
* OF U
*
IF( K.GT.2 ) THEN
*
* STORE U(K) AND U(K-1) IN COLUMNS K AND K-1 OF A
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / D21
D22 = W( K-1, KW-1 ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
20 CONTINUE
END IF
*
* COPY D(K) TO A
*
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
END IF
END IF
*
* STORE DETAILS OF THE INTERCHANGES IN IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* DECREASE K AND RETURN TO THE START OF THE MAIN LOOP
*
K = K - KSTEP
GO TO 10
*
30 CONTINUE
*
* UPDATE THE UPPER TRIANGLE OF A11 (= A(1:K,1:K)) AS
*
* A11 := A11 - U12*D*U12' = A11 - U12*W'
*
* COMPUTING BLOCKS OF NB COLUMNS AT A TIME
*
DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
JB = MIN( NB, K-J+1 )
*
* UPDATE THE UPPER TRIANGLE OF THE DIAGONAL BLOCK
*
DO 40 JJ = J, J + JB - 1
CALL DGEMV( 'NO TRANSPOSE', JJ-J+1, N-K, -ONE,
$ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE,
$ A( J, JJ ), 1 )
40 CONTINUE
*
* UPDATE THE RECTANGULAR SUPERDIAGONAL BLOCK
*
CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', J-1, JB, N-K, -ONE,
$ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE,
$ A( 1, J ), LDA )
50 CONTINUE
*
* PUT U12 IN STANDARD FORM BY PARTIALLY UNDOING THE INTERCHANGES
* IN COLUMNS K+1:N
*
J = K + 1
60 CONTINUE
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
J = J + 1
END IF
J = J + 1
IF( JP.NE.JJ .AND. J.LE.N )
$ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
IF( J.LE.N )
$ GO TO 60
*
* SET KB TO THE NUMBER OF COLUMNS FACTORIZED
*
KB = N - K
*
ELSE
*
* FACTORIZE THE LEADING COLUMNS OF A USING THE LOWER TRIANGLE
* OF A AND WORKING FORWARDS, AND COMPUTE THE MATRIX W = L21*D
* FOR USE IN UPDATING A22
*
* K IS THE MAIN LOOP INDEX, INCREASING FROM 1 IN STEPS OF 1 OR 2
*
K = 1
70 CONTINUE
*
* EXIT FROM LOOP
*
IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
$ GO TO 90
*
* COPY COLUMN K OF A TO COLUMN K OF W AND UPDATE IT
*
CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
CALL DGEMV( 'NO TRANSPOSE', N-K+1, K-1, -ONE, A( K, 1 ), LDA,
$ W( K, 1 ), LDW, ONE, W( K, K ), 1 )
*
KSTEP = 1
*
* DETERMINE ROWS AND COLUMNS TO BE INTERCHANGED AND WHETHER
* A 1-BY-1 OR 2-BY-2 PIVOT BLOCK WILL BE USED
*
ABSAKK = ABS( W( K, K ) )
*
* IMAX IS THE ROW-INDEX OF THE LARGEST OFF-DIAGONAL ELEMENT IN
* COLUMN K, AND COLMAX IS ITS ABSOLUTE VALUE
*
IF( K.LT.N ) THEN
IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 )
COLMAX = ABS( W( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* COLUMN K IS ZERO: SET INFO AND CONTINUE
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK
*
KP = K
ELSE
*
* COPY COLUMN IMAX TO COLUMN K+1 OF W AND UPDATE IT
*
CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ),
$ 1 )
CALL DGEMV( 'NO TRANSPOSE', N-K+1, K-1, -ONE, A( K, 1 ),
$ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 )
*
* JMAX IS THE COLUMN-INDEX OF THE LARGEST OFF-DIAGONAL
* ELEMENT IN ROW IMAX, AND ROWMAX IS ITS ABSOLUTE VALUE
*
JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 )
ROWMAX = ABS( W( JMAX, K+1 ) )
IF( IMAX.LT.N ) THEN
JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK
*
KP = K
ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN
*
* INTERCHANGE ROWS AND COLUMNS K AND IMAX, USE 1-BY-1
* PIVOT BLOCK
*
KP = IMAX
*
* COPY COLUMN K+1 OF W TO COLUMN K
*
CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
ELSE
*
* INTERCHANGE ROWS AND COLUMNS K+1 AND IMAX, USE 2-BY-2
* PIVOT BLOCK
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K + KSTEP - 1
*
* UPDATED COLUMN KP IS ALREADY STORED IN COLUMN KK OF W
*
IF( KP.NE.KK ) THEN
*
* COPY NON-UPDATED COLUMN KK TO COLUMN KP
*
A( KP, K ) = A( KK, K )
CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
*
* INTERCHANGE ROWS KK AND KP IN FIRST KK COLUMNS OF A AND W
*
CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-BY-1 PIVOT BLOCK D(K): COLUMN K OF W NOW HOLDS
*
* W(K) = L(K)*D(K)
*
* WHERE L(K) IS THE K-TH COLUMN OF L
*
* STORE L(K) IN COLUMN K OF A
*
CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
R1 = ONE / A( K, K )
CALL DSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
ELSE
*
* 2-BY-2 PIVOT BLOCK D(K): COLUMNS K AND K+1 OF W NOW HOLD
*
* ( W(K) W(K+1) ) = ( L(K) L(K+1) )*D(K)
*
* WHERE L(K) AND L(K+1) ARE THE K-TH AND (K+1)-TH COLUMNS
* OF L
*
IF( K.LT.N-1 ) THEN
*
* STORE L(K) AND L(K+1) IN COLUMNS K AND K+1 OF A
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
DO 80 J = K + 2, N
A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
80 CONTINUE
END IF
*
* COPY D(K) TO A
*
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
END IF
END IF
*
* STORE DETAILS OF THE INTERCHANGES IN IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* INCREASE K AND RETURN TO THE START OF THE MAIN LOOP
*
K = K + KSTEP
GO TO 70
*
90 CONTINUE
*
* UPDATE THE LOWER TRIANGLE OF A22 (= A(K:N,K:N)) AS
*
* A22 := A22 - L21*D*L21' = A22 - L21*W'
*
* COMPUTING BLOCKS OF NB COLUMNS AT A TIME
*
DO 110 J = K, N, NB
JB = MIN( NB, N-J+1 )
*
* UPDATE THE LOWER TRIANGLE OF THE DIAGONAL BLOCK
*
DO 100 JJ = J, J + JB - 1
CALL DGEMV( 'NO TRANSPOSE', J+JB-JJ, K-1, -ONE,
$ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE,
$ A( JJ, JJ ), 1 )
100 CONTINUE
*
* UPDATE THE RECTANGULAR SUBDIAGONAL BLOCK
*
IF( J+JB.LE.N )
$ CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', N-J-JB+1, JB,
$ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
$ ONE, A( J+JB, J ), LDA )
110 CONTINUE
*
* PUT L21 IN STANDARD FORM BY PARTIALLY UNDOING THE INTERCHANGES
* IN COLUMNS 1:K-1
*
J = K - 1
120 CONTINUE
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
J = J - 1
END IF
J = J - 1
IF( JP.NE.JJ .AND. J.GE.1 )
$ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
IF( J.GE.1 )
$ GO TO 120
*
* SET KB TO THE NUMBER OF COLUMNS FACTORIZED
*
KB = K - 1
*
END IF
RETURN
*
* END OF DLASYF
*
END
CUT HERE..........
C --------------------- BELOW IS DSYTRI ------------------
SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.0B) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* PURPOSE
* =======
*
* DSYTRI COMPUTES THE INVERSE OF A REAL SYMMETRIC INDEFINITE MATRIX
* A USING THE FACTORIZATION A = U*D*U' OR A = L*D*L' COMPUTED BY
* DSYTRF.
*
* ARGUMENTS
* =========
*
* UPLO (INPUT) CHARACTER*1
* SPECIFIES WHETHER THE DETAILS OF THE FACTORIZATION ARE STORED
* AS AN UPPER OR LOWER TRIANGULAR MATRIX.
* = 'U': UPPER TRIANGULAR (FORM IS A = U*D*U')
* = 'L': LOWER TRIANGULAR (FORM IS A = L*D*L')
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX A. N >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE BLOCK DIAGONAL MATRIX D AND THE MULTIPLIERS
* USED TO OBTAIN THE FACTOR U OR L AS COMPUTED BY DSYTRF.
*
* ON EXIT, IF INFO = 0, THE (SYMMETRIC) INVERSE OF THE ORIGINAL
* MATRIX. IF UPLO = 'U', THE UPPER TRIANGULAR PART OF THE
* INVERSE IS FORMED AND THE PART OF A BELOW THE DIAGONAL IS NOT
* REFERENCED; IF UPLO = 'L' THE LOWER TRIANGULAR PART OF THE
* INVERSE IS FORMED AND THE PART OF A ABOVE THE DIAGONAL IS
* NOT REFERENCED.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N).
*
* IPIV (INPUT) INTEGER ARRAY, DIMENSION (N)
* DETAILS OF THE INTERCHANGES AND THE BLOCK STRUCTURE OF D
* AS DETERMINED BY DSYTRF.
*
* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (N)
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -K, THE K-TH ARGUMENT HAD AN ILLEGAL VALUE
* > 0: IF INFO = K, D(K,K) = 0; THE MATRIX IS SINGULAR AND ITS
* INVERSE COULD NOT BE COMPUTED.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
LOGICAL UPPER
INTEGER K, KP, KSTEP
DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC ABS, MAX
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTRI', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( N.EQ.0 )
$ RETURN
*
* CHECK THAT THE DIAGONAL MATRIX D IS NONSINGULAR.
*
IF( UPPER ) THEN
*
* UPPER TRIANGULAR STORAGE: EXAMINE D FROM BOTTOM TO TOP
*
DO 10 INFO = N, 1, -1
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
*
* LOWER TRIANGULAR STORAGE: EXAMINE D FROM TOP TO BOTTOM.
*
DO 20 INFO = 1, N
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
INFO = 0
*
IF( UPPER ) THEN
*
* COMPUTE INV(A) FROM THE FACTORIZATION A = U*D*U'.
*
* K IS THE MAIN LOOP INDEX, INCREASING FROM 1 TO N IN STEPS OF
* 1 OR 2, DEPENDING ON THE SIZE OF THE DIAGONAL BLOCKS.
*
K = 1
30 CONTINUE
*
* IF K > N, EXIT FROM LOOP.
*
IF( K.GT.N )
$ GO TO 40
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 X 1 DIAGONAL BLOCK
*
* INVERT THE DIAGONAL BLOCK.
*
A( K, K ) = ONE / A( K, K )
*
* COMPUTE COLUMN K OF THE INVERSE.
*
IF( K.GT.1 ) THEN
CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 X 2 DIAGONAL BLOCK
*
* INVERT THE DIAGONAL BLOCK.
*
T = ABS( A( K, K+1 ) )
AK = A( K, K ) / T
AKP1 = A( K+1, K+1 ) / T
AKKP1 = A( K, K+1 ) / T
D = T*( AK*AKP1-ONE )
A( K, K ) = AKP1 / D
A( K+1, K+1 ) = AK / D
A( K, K+1 ) = -AKKP1 / D
*
* COMPUTE COLUMNS K AND K+1 OF THE INVERSE.
*
IF( K.GT.1 ) THEN
CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ),
$ 1 )
A( K, K+1 ) = A( K, K+1 ) -
$ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K+1 ), 1 )
A( K+1, K+1 ) = A( K+1, K+1 ) -
$ DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 )
END IF
KSTEP = 2
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* INTERCHANGE ROWS AND COLUMNS K AND KP IN THE LEADING
* SUBMATRIX A(1:K+1,1:K+1)
*
CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = A( K, K+1 )
A( K, K+1 ) = A( KP, K+1 )
A( KP, K+1 ) = TEMP
END IF
END IF
*
K = K + KSTEP
GO TO 30
40 CONTINUE
*
ELSE
*
* COMPUTE INV(A) FROM THE FACTORIZATION A = L*D*L'.
*
* K IS THE MAIN LOOP INDEX, INCREASING FROM 1 TO N IN STEPS OF
* 1 OR 2, DEPENDING ON THE SIZE OF THE DIAGONAL BLOCKS.
*
K = N
50 CONTINUE
*
* IF K < 1, EXIT FROM LOOP.
*
IF( K.LT.1 )
$ GO TO 60
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 X 1 DIAGONAL BLOCK
*
* INVERT THE DIAGONAL BLOCK.
*
A( K, K ) = ONE / A( K, K )
*
* COMPUTE COLUMN K OF THE INVERSE.
*
IF( K.LT.N ) THEN
CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
$ ZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 X 2 DIAGONAL BLOCK
*
* INVERT THE DIAGONAL BLOCK.
*
T = ABS( A( K, K-1 ) )
AK = A( K-1, K-1 ) / T
AKP1 = A( K, K ) / T
AKKP1 = A( K, K-1 ) / T
D = T*( AK*AKP1-ONE )
A( K-1, K-1 ) = AKP1 / D
A( K, K ) = AK / D
A( K, K-1 ) = -AKKP1 / D
*
* COMPUTE COLUMNS K-1 AND K OF THE INVERSE.
*
IF( K.LT.N ) THEN
CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
$ ZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ),
$ 1 )
A( K, K-1 ) = A( K, K-1 ) -
$ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
$ 1 )
CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
$ ZERO, A( K+1, K-1 ), 1 )
A( K-1, K-1 ) = A( K-1, K-1 ) -
$ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 )
END IF
KSTEP = 2
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* INTERCHANGE ROWS AND COLUMNS K AND KP IN THE TRAILING
* SUBMATRIX A(K-1:N,K-1:N)
*
IF( KP.LT.N )
$ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = A( K, K-1 )
A( K, K-1 ) = A( KP, K-1 )
A( KP, K-1 ) = TEMP
END IF
END IF
*
K = K - KSTEP
GO TO 50
60 CONTINUE
END IF
*
RETURN
*
* END OF DSYTRI
*
END
C ------------------ BELOW IS DGESV ------------------------
SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK DRIVER ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* PURPOSE
* =======
*
* DGESV COMPUTES THE SOLUTION TO A REAL SYSTEM OF LINEAR EQUATIONS
* A * X = B,
* WHERE A IS AN N-BY-N MATRIX AND X AND B ARE N-BY-NRHS MATRICES.
*
* THE LU DECOMPOSITION WITH PARTIAL PIVOTING AND ROW INTERCHANGES IS
* USED TO FACTOR A AS
* A = P * L * U,
* WHERE P IS A PERMUTATION MATRIX, L IS UNIT LOWER TRIANGULAR, AND U IS
* UPPER TRIANGULAR. THE FACTORED FORM OF A IS THEN USED TO SOLVE THE
* SYSTEM OF EQUATIONS A * X = B.
*
* ARGUMENTS
* =========
*
* N (INPUT) INTEGER
* THE NUMBER OF LINEAR EQUATIONS, I.E., THE ORDER OF THE
* MATRIX A. N >= 0.
*
* NRHS (INPUT) INTEGER
* THE NUMBER OF RIGHT HAND SIDES, I.E., THE NUMBER OF COLUMNS
* OF THE MATRIX B. NRHS >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE N-BY-N COEFFICIENT MATRIX A.
* ON EXIT, THE FACTORS L AND U FROM THE FACTORIZATION
* A = P*L*U; THE UNIT DIAGONAL ELEMENTS OF L ARE NOT STORED.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N).
*
* IPIV (OUTPUT) INTEGER ARRAY, DIMENSION (N)
* THE PIVOT INDICES THAT DEFINE THE PERMUTATION MATRIX P;
* ROW I OF THE MATRIX WAS INTERCHANGED WITH ROW IPIV(I).
*
* B (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDB,NRHS)
* ON ENTRY, THE N-BY-NRHS MATRIX OF RIGHT HAND SIDE MATRIX B.
* ON EXIT, IF INFO = 0, THE N-BY-NRHS SOLUTION MATRIX X.
*
* LDB (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY B. LDB >= MAX(1,N).
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
* > 0: IF INFO = I, U(I,I) IS EXACTLY ZERO. THE FACTORIZATION
* HAS BEEN COMPLETED, BUT THE FACTOR U IS EXACTLY
* SINGULAR, SO THE SOLUTION COULD NOT BE COMPUTED.
*
* =====================================================================
*
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DGETRF, DGETRS, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGESV ', -INFO )
RETURN
END IF
*
* COMPUTE THE LU FACTORIZATION OF A.
*
CALL DGETRF( N, N, A, LDA, IPIV, INFO )
IF( INFO.EQ.0 ) THEN
*
* SOLVE THE SYSTEM A*X = B, OVERWRITING B WITH X.
*
CALL DGETRS( 'NO TRANSPOSE', N, NRHS, A, LDA, IPIV, B, LDB,
$ INFO )
END IF
RETURN
*
* END OF DGESV
*
END
CUT HERE............
CAT > DGETRS.F <<'CUT HERE............'
SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
CHARACTER TRANS
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* PURPOSE
* =======
*
* DGETRS SOLVES A SYSTEM OF LINEAR EQUATIONS
* A * X = B OR A' * X = B
* WITH A GENERAL N-BY-N MATRIX A USING THE LU FACTORIZATION COMPUTED
* BY DGETRF.
*
* ARGUMENTS
* =========
*
* TRANS (INPUT) CHARACTER*1
* SPECIFIES THE FORM OF THE SYSTEM OF EQUATIONS:
* = 'N': A * X = B (NO TRANSPOSE)
* = 'T': A'* X = B (TRANSPOSE)
* = 'C': A'* X = B (CONJUGATE TRANSPOSE = TRANSPOSE)
*
* N (INPUT) INTEGER
* THE ORDER OF THE MATRIX A. N >= 0.
*
* NRHS (INPUT) INTEGER
* THE NUMBER OF RIGHT HAND SIDES, I.E., THE NUMBER OF COLUMNS
* OF THE MATRIX B. NRHS >= 0.
*
* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* THE FACTORS L AND U FROM THE FACTORIZATION A = P*L*U
* AS COMPUTED BY DGETRF.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N).
*
* IPIV (INPUT) INTEGER ARRAY, DIMENSION (N)
* THE PIVOT INDICES FROM DGETRF; FOR 1<=I<=N, ROW I OF THE
* MATRIX WAS INTERCHANGED WITH ROW IPIV(I).
*
* B (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDB,NRHS)
* ON ENTRY, THE RIGHT HAND SIDE MATRIX B.
* ON EXIT, THE SOLUTION MATRIX X.
*
* LDB (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY B. LDB >= MAX(1,N).
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. LOCAL SCALARS ..
LOGICAL NOTRAN
* ..
* .. EXTERNAL FUNCTIONS ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DLASWP, DTRSM, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS.
*
INFO = 0
NOTRAN = LSAME( TRANS, 'N' )
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGETRS', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( NOTRAN ) THEN
*
* SOLVE A * X = B.
*
* APPLY ROW INTERCHANGES TO THE RIGHT HAND SIDES.
*
CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
*
* SOLVE L*X = B, OVERWRITING B WITH X.
*
CALL DTRSM( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
* SOLVE U*X = B, OVERWRITING B WITH X.
*
CALL DTRSM( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', N,
$ NRHS, ONE, A, LDA, B, LDB )
ELSE
*
* SOLVE A' * X = B.
*
* SOLVE U'*X = B, OVERWRITING B WITH X.
*
CALL DTRSM( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
* SOLVE L'*X = B, OVERWRITING B WITH X.
*
CALL DTRSM( 'LEFT', 'LOWER', 'TRANSPOSE', 'UNIT', N, NRHS, ONE,
$ A, LDA, B, LDB )
*
* APPLY ROW INTERCHANGES TO THE SOLUTION VECTORS.
*
CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
END IF
*
RETURN
*
* END OF DGETRS
*
END
CUT HERE............
CAT > DGETRF.F <<'CUT HERE............'
SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* MARCH 31, 1993
*
* .. SCALAR ARGUMENTS ..
INTEGER INFO, LDA, M, N
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * )
* ..
*
* PURPOSE
* =======
*
* DGETRF COMPUTES AN LU FACTORIZATION OF A GENERAL M-BY-N MATRIX A
* USING PARTIAL PIVOTING WITH ROW INTERCHANGES.
*
* THE FACTORIZATION HAS THE FORM
* A = P * L * U
* WHERE P IS A PERMUTATION MATRIX, L IS LOWER TRIANGULAR WITH UNIT
* DIAGONAL ELEMENTS (LOWER TRAPEZOIDAL IF M > N), AND U IS UPPER
* TRIANGULAR (UPPER TRAPEZOIDAL IF M < N).
*
* THIS IS THE RIGHT-LOOKING LEVEL 3 BLAS VERSION OF THE ALGORITHM.
*
* ARGUMENTS
* =========
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX A. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX A. N >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE M-BY-N MATRIX TO BE FACTORED.
* ON EXIT, THE FACTORS L AND U FROM THE FACTORIZATION
* A = P*L*U; THE UNIT DIAGONAL ELEMENTS OF L ARE NOT STORED.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,M).
*
* IPIV (OUTPUT) INTEGER ARRAY, DIMENSION (MIN(M,N))
* THE PIVOT INDICES; FOR 1 <= I <= MIN(M,N), ROW I OF THE
* MATRIX WAS INTERCHANGED WITH ROW IPIV(I).
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE
* > 0: IF INFO = I, U(I,I) IS EXACTLY ZERO. THE FACTORIZATION
* HAS BEEN COMPLETED, BUT THE FACTOR U IS EXACTLY
* SINGULAR, AND DIVISION BY ZERO WILL OCCUR IF IT IS USED
* TO SOLVE A SYSTEM OF EQUATIONS.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER I, IINFO, J, JB, NB
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA
* ..
* .. EXTERNAL FUNCTIONS ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX, MIN
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGETRF', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* DETERMINE THE BLOCK SIZE FOR THIS ENVIRONMENT.
*
NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
*
* USE UNBLOCKED CODE.
*
CALL DGETF2( M, N, A, LDA, IPIV, INFO )
ELSE
*
* USE BLOCKED CODE.
*
DO 20 J = 1, MIN( M, N ), NB
JB = MIN( MIN( M, N )-J+1, NB )
*
* FACTOR DIAGONAL AND SUBDIAGONAL BLOCKS AND TEST FOR EXACT
* SINGULARITY.
*
CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
*
* ADJUST INFO AND THE PIVOT INDICES.
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + J - 1
DO 10 I = J, MIN( M, J+JB-1 )
IPIV( I ) = J - 1 + IPIV( I )
10 CONTINUE
*
* APPLY INTERCHANGES TO COLUMNS 1:J-1.
*
CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
*
IF( J+JB.LE.N ) THEN
*
* APPLY INTERCHANGES TO COLUMNS J+JB:N.
*
CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
$ IPIV, 1 )
*
* COMPUTE BLOCK ROW OF U.
*
CALL DTRSM( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', JB,
$ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
$ LDA )
IF( J+JB.LE.M ) THEN
*
* UPDATE TRAILING SUBMATRIX.
*
CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', M-J-JB+1,
$ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
$ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
$ LDA )
END IF
END IF
20 CONTINUE
END IF
RETURN
*
* END OF DGETRF
*
END
CUT HERE............
CAT > DLASWP.F <<'CUT HERE............'
SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* OCTOBER 31, 1992
*
* .. SCALAR ARGUMENTS ..
INTEGER INCX, K1, K2, LDA, N
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * )
* ..
*
* PURPOSE
* =======
*
* DLASWP PERFORMS A SERIES OF ROW INTERCHANGES ON THE MATRIX A.
* ONE ROW INTERCHANGE IS INITIATED FOR EACH OF ROWS K1 THROUGH K2 OF A.
*
* ARGUMENTS
* =========
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX A.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE MATRIX OF COLUMN DIMENSION N TO WHICH THE ROW
* INTERCHANGES WILL BE APPLIED.
* ON EXIT, THE PERMUTED MATRIX.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A.
*
* K1 (INPUT) INTEGER
* THE FIRST ELEMENT OF IPIV FOR WHICH A ROW INTERCHANGE WILL
* BE DONE.
*
* K2 (INPUT) INTEGER
* THE LAST ELEMENT OF IPIV FOR WHICH A ROW INTERCHANGE WILL
* BE DONE.
*
* IPIV (INPUT) INTEGER ARRAY, DIMENSION (M*ABS(INCX))
* THE VECTOR OF PIVOT INDICES. ONLY THE ELEMENTS IN POSITIONS
* K1 THROUGH K2 OF IPIV ARE ACCESSED.
* IPIV(K) = L IMPLIES ROWS K AND L ARE TO BE INTERCHANGED.
*
* INCX (INPUT) INTEGER
* THE INCREMENT BETWEEN SUCCESSIVE VALUES OF IPIV. IF IPIV
* IS NEGATIVE, THE PIVOTS ARE APPLIED IN REVERSE ORDER.
*
* =====================================================================
*
* .. LOCAL SCALARS ..
INTEGER I, IP, IX
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DSWAP
* ..
* .. EXECUTABLE STATEMENTS ..
*
* INTERCHANGE ROW I WITH ROW IPIV(I) FOR EACH OF ROWS K1 THROUGH K2.
*
IF( INCX.EQ.0 )
$ RETURN
IF( INCX.GT.0 ) THEN
IX = K1
ELSE
IX = 1 + ( 1-K2 )*INCX
END IF
IF( INCX.EQ.1 ) THEN
DO 10 I = K1, K2
IP = IPIV( I )
IF( IP.NE.I )
$ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
10 CONTINUE
ELSE IF( INCX.GT.1 ) THEN
DO 20 I = K1, K2
IP = IPIV( IX )
IF( IP.NE.I )
$ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
IX = IX + INCX
20 CONTINUE
ELSE IF( INCX.LT.0 ) THEN
DO 30 I = K2, K1, -1
IP = IPIV( IX )
IF( IP.NE.I )
$ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
IX = IX + INCX
30 CONTINUE
END IF
*
RETURN
*
* END OF DLASWP
*
END
CUT HERE............
CAT > DGETF2.F <<'CUT HERE............'
SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK ROUTINE (VERSION 1.1) --
* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD.,
* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY
* JUNE 30, 1992
*
* .. SCALAR ARGUMENTS ..
INTEGER INFO, LDA, M, N
* ..
* .. ARRAY ARGUMENTS ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * )
* ..
*
* PURPOSE
* =======
*
* DGETF2 COMPUTES AN LU FACTORIZATION OF A GENERAL M-BY-N MATRIX A
* USING PARTIAL PIVOTING WITH ROW INTERCHANGES.
*
* THE FACTORIZATION HAS THE FORM
* A = P * L * U
* WHERE P IS A PERMUTATION MATRIX, L IS LOWER TRIANGULAR WITH UNIT
* DIAGONAL ELEMENTS (LOWER TRAPEZOIDAL IF M > N), AND U IS UPPER
* TRIANGULAR (UPPER TRAPEZOIDAL IF M < N).
*
* THIS IS THE RIGHT-LOOKING LEVEL 2 BLAS VERSION OF THE ALGORITHM.
*
* ARGUMENTS
* =========
*
* M (INPUT) INTEGER
* THE NUMBER OF ROWS OF THE MATRIX A. M >= 0.
*
* N (INPUT) INTEGER
* THE NUMBER OF COLUMNS OF THE MATRIX A. N >= 0.
*
* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N)
* ON ENTRY, THE M BY N MATRIX TO BE FACTORED.
* ON EXIT, THE FACTORS L AND U FROM THE FACTORIZATION
* A = P*L*U; THE UNIT DIAGONAL ELEMENTS OF L ARE NOT STORED.
*
* LDA (INPUT) INTEGER
* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,M).
*
* IPIV (OUTPUT) INTEGER ARRAY, DIMENSION (MIN(M,N))
* THE PIVOT INDICES; FOR 1 <= I <= MIN(M,N), ROW I OF THE
* MATRIX WAS INTERCHANGED WITH ROW IPIV(I).
*
* INFO (OUTPUT) INTEGER
* = 0: SUCCESSFUL EXIT
* < 0: IF INFO = -K, THE K-TH ARGUMENT HAD AN ILLEGAL VALUE
* > 0: IF INFO = K, U(K,K) IS EXACTLY ZERO. THE FACTORIZATION
* HAS BEEN COMPLETED, BUT THE FACTOR U IS EXACTLY
* SINGULAR, AND DIVISION BY ZERO WILL OCCUR IF IT IS USED
* TO SOLVE A SYSTEM OF EQUATIONS.
*
* =====================================================================
*
* .. PARAMETERS ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. LOCAL SCALARS ..
INTEGER J, JP
* ..
* .. EXTERNAL FUNCTIONS ..
INTEGER IDAMAX
EXTERNAL IDAMAX
* ..
* .. EXTERNAL SUBROUTINES ..
EXTERNAL DGER, DSCAL, DSWAP, XERBLA
* ..
* .. INTRINSIC FUNCTIONS ..
INTRINSIC MAX, MIN
* ..
* .. EXECUTABLE STATEMENTS ..
*
* TEST THE INPUT PARAMETERS.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGETF2', -INFO )
RETURN
END IF
*
* QUICK RETURN IF POSSIBLE
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
DO 10 J = 1, MIN( M, N )
*
* FIND PIVOT AND TEST FOR SINGULARITY.
*
JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 )
IPIV( J ) = JP
IF( A( JP, J ).NE.ZERO ) THEN
*
* APPLY THE INTERCHANGE TO COLUMNS 1:N.
*
IF( JP.NE.J )
$ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
*
* COMPUTE ELEMENTS J+1:M OF J-TH COLUMN.
*
IF( J.LT.M )
$ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
*
ELSE IF( INFO.EQ.0 ) THEN
*
INFO = J
END IF
*
IF( J.LT.MIN( M, N ) ) THEN
*
* UPDATE TRAILING SUBMATRIX.
*
CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,
$ A( J+1, J+1 ), LDA )
END IF
10 CONTINUE
RETURN
*
* END OF DGETF2
*
END
CUT HERE............
Reference in New Issue View Git Blame Copy Permalink