SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
$ LRWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a
* complex Hermitian matrix A. If eigenvectors are desired, it uses a
* divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) COMPLEX*16 array, dimension (LDA, N)
* On entry, the Hermitian matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
* orthonormal eigenvectors of the matrix A.
* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
* or the upper triangle (if UPLO='U') of A, including the
* diagonal, is destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length of the array WORK.
* If N <= 1, LWORK must be at least 1.
* If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.
* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK, RWORK and
* IWORK arrays, returns these values as the first entries of
* the WORK, RWORK and IWORK arrays, and no error message
* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*
* RWORK (workspace/output) DOUBLE PRECISION array,
* dimension (LRWORK)
* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
*
* LRWORK (input) INTEGER
* The dimension of the array RWORK.
* If N <= 1, LRWORK must be at least 1.
* If JOBZ = 'N' and N > 1, LRWORK must be at least N.
* If JOBZ = 'V' and N > 1, LRWORK must be at least
* 1 + 5*N + 2*N**2.
*
* If LRWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK, RWORK
* and IWORK arrays, returns these values as the first entries
* of the WORK, RWORK and IWORK arrays, and no error message
* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If N <= 1, LIWORK must be at least 1.
* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK, RWORK
* and IWORK arrays, returns these values as the first entries
* of the WORK, RWORK and IWORK arrays, and no error message
* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed
* to converge; i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero;
* if INFO = i and JOBZ = 'V', then the algorithm failed
* to compute an eigenvalue while working on the submatrix
* lying in rows and columns INFO/(N+1) through
* mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* Modified description of INFO. Sven, 16 Feb 05.
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) )
* ..
* .. Local Scalars ..
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWK2,
$ INDWRK, ISCALE, LIOPT, LIWMIN, LLRWK, LLWORK,
$ LLWRK2, LOPT, LROPT, LRWMIN, LWMIN
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANHE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLACPY, ZLASCL,
$ ZSTEDC, ZUNMTR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LWMIN = 1
LRWMIN = 1
LIWMIN = 1
LOPT = LWMIN
LROPT = LRWMIN
LIOPT = LIWMIN
ELSE
IF( WANTZ ) THEN
LWMIN = 2*N + N*N
LRWMIN = 1 + 5*N + 2*N**2
LIWMIN = 3 + 5*N
ELSE
LWMIN = N + 1
LRWMIN = N
LIWMIN = 1
END IF
LOPT = MAX( LWMIN, N +
$ ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) )
LROPT = LRWMIN
LIOPT = LIWMIN
END IF
WORK( 1 ) = LOPT
RWORK( 1 ) = LROPT
IWORK( 1 ) = LIOPT
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHEEVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = A( 1, 1 )
IF( WANTZ )
$ A( 1, 1 ) = CONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 )
$ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
*
* Call ZHETRD to reduce Hermitian matrix to tridiagonal form.
*
INDE = 1
INDTAU = 1
INDWRK = INDTAU + N
INDRWK = INDE + N
INDWK2 = INDWRK + N*N
LLWORK = LWORK - INDWRK + 1
LLWRK2 = LWORK - INDWK2 + 1
LLRWK = LRWORK - INDRWK + 1
CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
* tridiagonal matrix, then call ZUNMTR to multiply it to the
* Householder transformations represented as Householder vectors in
* A.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, RWORK( INDE ), INFO )
ELSE
CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N,
$ WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK,
$ IWORK, LIWORK, INFO )
CALL ZUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
$ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
CALL ZLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
WORK( 1 ) = LOPT
RWORK( 1 ) = LROPT
IWORK( 1 ) = LIOPT
*
RETURN
*
* End of ZHEEVD
*
END
DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 A( LDA, * )
* ..
*
* Purpose
* =======
*
* ZLANHE returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* complex hermitian matrix A.
*
* Description
* ===========
*
* ZLANHE returns the value
*
* ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in ZLANHE as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* hermitian matrix A is to be referenced.
* = 'U': Upper triangular part of A is referenced
* = 'L': Lower triangular part of A is referenced
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, ZLANHE is
* set to zero.
*
* A (input) COMPLEX*16 array, dimension (LDA,N)
* The hermitian matrix A. If UPLO = 'U', the leading n by n
* upper triangular part of A contains the upper triangular part
* of the matrix A, and the strictly lower triangular part of A
* is not referenced. If UPLO = 'L', the leading n by n lower
* triangular part of A contains the lower triangular part of
* the matrix A, and the strictly upper triangular part of A is
* not referenced. Note that the imaginary parts of the diagonal
* elements need not be set and are assumed to be zero.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(N,1).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J - 1
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
10 CONTINUE
VALUE = MAX( VALUE, ABS( DBLE( A( J, J ) ) ) )
20 CONTINUE
ELSE
DO 40 J = 1, N
VALUE = MAX( VALUE, ABS( DBLE( A( J, J ) ) ) )
DO 30 I = J + 1, N
VALUE = MAX( VALUE, ABS( A( I, J ) ) )
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is hermitian).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
50 CONTINUE
WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) )
60 CONTINUE
DO 70 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) )
DO 90 I = J + 1, N
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
90 CONTINUE
VALUE = MAX( VALUE, SUM )
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
120 CONTINUE
END IF
SUM = 2*SUM
DO 130 I = 1, N
IF( DBLE( A( I, I ) ).NE.ZERO ) THEN
ABSA = ABS( DBLE( A( I, I ) ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
130 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANHE = VALUE
RETURN
*
* End of ZLANHE
*
END
SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* Purpose
* =======
*
* ZLACPY copies all or part of a two-dimensional matrix A to another
* matrix B.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies the part of the matrix A to be copied to B.
* = 'U': Upper triangular part
* = 'L': Lower triangular part
* Otherwise: All of the matrix A
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0.
*
* A (input) COMPLEX*16 array, dimension (LDA,N)
* The m by n matrix A. If UPLO = 'U', only the upper trapezium
* is accessed; if UPLO = 'L', only the lower trapezium is
* accessed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* B (output) COMPLEX*16 array, dimension (LDB,N)
* On exit, B = A in the locations specified by UPLO.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,M).
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, MIN( J, M )
B( I, J ) = A( I, J )
10 CONTINUE
20 CONTINUE
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
DO 40 J = 1, N
DO 30 I = J, M
B( I, J ) = A( I, J )
30 CONTINUE
40 CONTINUE
*
ELSE
DO 60 J = 1, N
DO 50 I = 1, M
B( I, J ) = A( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
RETURN
*
* End of ZLACPY
*
END
SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TYPE
INTEGER INFO, KL, KU, LDA, M, N
DOUBLE PRECISION CFROM, CTO
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* Purpose
* =======
*
* ZLASCL multiplies the M by N complex matrix A by the real scalar
* CTO/CFROM. This is done without over/underflow as long as the final
* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
* A may be full, upper triangular, lower triangular, upper Hessenberg,
* or banded.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*1
* TYPE indices the storage type of the input matrix.
* = 'G': A is a full matrix.
* = 'L': A is a lower triangular matrix.
* = 'U': A is an upper triangular matrix.
* = 'H': A is an upper Hessenberg matrix.
* = 'B': A is a symmetric band matrix with lower bandwidth KL
* and upper bandwidth KU and with the only the lower
* half stored.
* = 'Q': A is a symmetric band matrix with lower bandwidth KL
* and upper bandwidth KU and with the only the upper
* half stored.
* = 'Z': A is a band matrix with lower bandwidth KL and upper
* bandwidth KU.
*
* KL (input) INTEGER
* The lower bandwidth of A. Referenced only if TYPE = 'B',
* 'Q' or 'Z'.
*
* KU (input) INTEGER
* The upper bandwidth of A. Referenced only if TYPE = 'B',
* 'Q' or 'Z'.
*
* CFROM (input) DOUBLE PRECISION
* CTO (input) DOUBLE PRECISION
* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
* without over/underflow if the final result CTO*A(I,J)/CFROM
* can be represented without over/underflow. CFROM must be
* nonzero.
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0.
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* The matrix to be multiplied by CTO/CFROM. See TYPE for the
* storage type.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* INFO (output) INTEGER
* 0 - successful exit
* <0 - if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
INTEGER I, ITYPE, J, K1, K2, K3, K4
DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH, DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
*
IF( LSAME( TYPE, 'G' ) ) THEN
ITYPE = 0
ELSE IF( LSAME( TYPE, 'L' ) ) THEN
ITYPE = 1
ELSE IF( LSAME( TYPE, 'U' ) ) THEN
ITYPE = 2
ELSE IF( LSAME( TYPE, 'H' ) ) THEN
ITYPE = 3
ELSE IF( LSAME( TYPE, 'B' ) ) THEN
ITYPE = 4
ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
ITYPE = 5
ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
ITYPE = 6
ELSE
ITYPE = -1
END IF
*
IF( ITYPE.EQ.-1 ) THEN
INFO = -1
ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
INFO = -4
ELSE IF( DISNAN(CTO) ) THEN
INFO = -5
ELSE IF( M.LT.0 ) THEN
INFO = -6
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
$ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
INFO = -7
ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
INFO = -9
ELSE IF( ITYPE.GE.4 ) THEN
IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
INFO = -2
ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
$ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
$ THEN
INFO = -3
ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
$ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
$ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
INFO = -9
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLASCL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
CFROMC = CFROM
CTOC = CTO
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
IF( CFROM1.EQ.CFROMC ) THEN
! CFROMC is an inf. Multiply by a correctly signed zero for
! finite CTOC, or a NaN if CTOC is infinite.
MUL = CTOC / CFROMC
DONE = .TRUE.
CTO1 = CTOC
ELSE
CTO1 = CTOC / BIGNUM
IF( CTO1.EQ.CTOC ) THEN
! CTOC is either 0 or an inf. In both cases, CTOC itself
! serves as the correct multiplication factor.
MUL = CTOC
DONE = .TRUE.
CFROMC = ONE
ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
MUL = SMLNUM
DONE = .FALSE.
CFROMC = CFROM1
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
MUL = BIGNUM
DONE = .FALSE.
CTOC = CTO1
ELSE
MUL = CTOC / CFROMC
DONE = .TRUE.
END IF
END IF
*
IF( ITYPE.EQ.0 ) THEN
*
* Full matrix
*
DO 30 J = 1, N
DO 20 I = 1, M
A( I, J ) = A( I, J )*MUL
20 CONTINUE
30 CONTINUE
*
ELSE IF( ITYPE.EQ.1 ) THEN
*
* Lower triangular matrix
*
DO 50 J = 1, N
DO 40 I = J, M
A( I, J ) = A( I, J )*MUL
40 CONTINUE
50 CONTINUE
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Upper triangular matrix
*
DO 70 J = 1, N
DO 60 I = 1, MIN( J, M )
A( I, J ) = A( I, J )*MUL
60 CONTINUE
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Upper Hessenberg matrix
*
DO 90 J = 1, N
DO 80 I = 1, MIN( J+1, M )
A( I, J ) = A( I, J )*MUL
80 CONTINUE
90 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Lower half of a symmetric band matrix
*
K3 = KL + 1
K4 = N + 1
DO 110 J = 1, N
DO 100 I = 1, MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
100 CONTINUE
110 CONTINUE
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Upper half of a symmetric band matrix
*
K1 = KU + 2
K3 = KU + 1
DO 130 J = 1, N
DO 120 I = MAX( K1-J, 1 ), K3
A( I, J ) = A( I, J )*MUL
120 CONTINUE
130 CONTINUE
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Band matrix
*
K1 = KL + KU + 2
K2 = KL + 1
K3 = 2*KL + KU + 1
K4 = KL + KU + 1 + M
DO 150 J = 1, N
DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
140 CONTINUE
150 CONTINUE
*
END IF
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of ZLASCL
*
END
SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK,
$ LRWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), RWORK( * )
COMPLEX*16 WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a
* symmetric tridiagonal matrix using the divide and conquer method.
* The eigenvectors of a full or band complex Hermitian matrix can also
* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
* matrix to tridiagonal form.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none. See DLAED3 for details.
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'I': Compute eigenvectors of tridiagonal matrix also.
* = 'V': Compute eigenvectors of original Hermitian matrix
* also. On entry, Z contains the unitary matrix used
* to reduce the original matrix to tridiagonal form.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal 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 subdiagonal elements of the tridiagonal matrix.
* On exit, E has been destroyed.
*
* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
* On entry, if COMPZ = 'V', then Z contains the unitary
* matrix used in the reduction to tridiagonal form.
* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
* orthonormal eigenvectors of the original Hermitian matrix,
* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
* of the symmetric tridiagonal matrix.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If eigenvectors are desired, then LDZ >= max(1,N).
*
* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.
* If COMPZ = 'V' and N > 1, LWORK must be at least N*N.
* Note that for COMPZ = 'V', then if N is less than or
* equal to the minimum divide size, usually 25, then LWORK need
* only be 1.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK, RWORK and
* IWORK arrays, returns these values as the first entries of
* the WORK, RWORK and IWORK arrays, and no error message
* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*
* RWORK (workspace/output) DOUBLE PRECISION array,
* dimension (LRWORK)
* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
*
* LRWORK (input) INTEGER
* The dimension of the array RWORK.
* If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.
* If COMPZ = 'V' and N > 1, LRWORK must be at least
* 1 + 3*N + 2*N*lg N + 3*N**2 ,
* where lg( N ) = smallest integer k such
* that 2**k >= N.
* If COMPZ = 'I' and N > 1, LRWORK must be at least
* 1 + 4*N + 2*N**2 .
* Note that for COMPZ = 'I' or 'V', then if N is less than or
* equal to the minimum divide size, usually 25, then LRWORK
* need only be max(1,2*(N-1)).
*
* If LRWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK, RWORK
* and IWORK arrays, returns these values as the first entries
* of the WORK, RWORK and IWORK arrays, and no error message
* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.
* If COMPZ = 'V' or N > 1, LIWORK must be at least
* 6 + 6*N + 5*N*lg N.
* If COMPZ = 'I' or N > 1, LIWORK must be at least
* 3 + 5*N .
* Note that for COMPZ = 'I' or 'V', then if N is less than or
* equal to the minimum divide size, usually 25, then LIWORK
* need only be 1.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK, RWORK
* and IWORK arrays, returns these values as the first entries
* of the WORK, RWORK and IWORK arrays, and no error message
* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an eigenvalue while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, LL,
$ LRWMIN, LWMIN, M, SMLSIZ, START
DOUBLE PRECISION EPS, ORGNRM, P, TINY
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DLASCL, DLASET, DSTEDC, DSTEQR, DSTERF, XERBLA,
$ ZLACPY, ZLACRM, ZLAED0, ZSTEQR, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
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.EQ.0 ) THEN
*
* Compute the workspace requirements
*
SMLSIZ = ILAENV( 9, 'ZSTEDC', ' ', 0, 0, 0, 0 )
IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
LWMIN = 1
LIWMIN = 1
LRWMIN = 1
ELSE IF( N.LE.SMLSIZ ) THEN
LWMIN = 1
LIWMIN = 1
LRWMIN = 2*( N - 1 )
ELSE IF( ICOMPZ.EQ.1 ) THEN
LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
LWMIN = N*N
LRWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
LIWMIN = 6 + 6*N + 5*N*LGN
ELSE IF( ICOMPZ.EQ.2 ) THEN
LWMIN = 1
LRWMIN = 1 + 4*N + 2*N**2
LIWMIN = 3 + 5*N
END IF
WORK( 1 ) = LWMIN
RWORK( 1 ) = LRWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSTEDC', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 ) THEN
IF( ICOMPZ.NE.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* If the following conditional clause is removed, then the routine
* will use the Divide and Conquer routine to compute only the
* eigenvalues, which requires (3N + 3N**2) real workspace and
* (2 + 5N + 2N lg(N)) integer workspace.
* Since on many architectures DSTERF is much faster than any other
* algorithm for finding eigenvalues only, it is used here
* as the default. If the conditional clause is removed, then
* information on the size of workspace needs to be changed.
*
* If COMPZ = 'N', use DSTERF to compute the eigenvalues.
*
IF( ICOMPZ.EQ.0 ) THEN
CALL DSTERF( N, D, E, INFO )
GO TO 70
END IF
*
* If N is smaller than the minimum divide size (SMLSIZ+1), then
* solve the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
*
CALL ZSTEQR( COMPZ, N, D, E, Z, LDZ, RWORK, INFO )
*
ELSE
*
* If COMPZ = 'I', we simply call DSTEDC instead.
*
IF( ICOMPZ.EQ.2 ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, RWORK, N )
LL = N*N + 1
CALL DSTEDC( 'I', N, D, E, RWORK, N,
$ RWORK( LL ), LRWORK-LL+1, IWORK, LIWORK, INFO )
DO 20 J = 1, N
DO 10 I = 1, N
Z( I, J ) = RWORK( ( J-1 )*N+I )
10 CONTINUE
20 CONTINUE
GO TO 70
END IF
*
* From now on, only option left to be handled is COMPZ = 'V',
* i.e. ICOMPZ = 1.
*
* Scale.
*
ORGNRM = DLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ GO TO 70
*
EPS = DLAMCH( 'Epsilon' )
*
START = 1
*
* while ( START <= N )
*
30 CONTINUE
IF( START.LE.N ) THEN
*
* Let FINISH be the position of the next subdiagonal entry
* such that E( FINISH ) <= TINY or FINISH = N if no such
* subdiagonal exists. The matrix identified by the elements
* between START and FINISH constitutes an independent
* sub-problem.
*
FINISH = START
40 CONTINUE
IF( FINISH.LT.N ) THEN
TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
$ SQRT( ABS( D( FINISH+1 ) ) )
IF( ABS( E( FINISH ) ).GT.TINY ) THEN
FINISH = FINISH + 1
GO TO 40
END IF
END IF
*
* (Sub) Problem determined. Compute its size and solve it.
*
M = FINISH - START + 1
IF( M.GT.SMLSIZ ) THEN
*
* Scale.
*
ORGNRM = DLANST( 'M', M, D( START ), E( START ) )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
$ INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
$ M-1, INFO )
*
CALL ZLAED0( N, M, D( START ), E( START ), Z( 1, START ),
$ LDZ, WORK, N, RWORK, IWORK, INFO )
IF( INFO.GT.0 ) THEN
INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
$ MOD( INFO, ( M+1 ) ) + START - 1
GO TO 70
END IF
*
* Scale back.
*
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
$ INFO )
*
ELSE
CALL DSTEQR( 'I', M, D( START ), E( START ), RWORK, M,
$ RWORK( M*M+1 ), INFO )
CALL ZLACRM( N, M, Z( 1, START ), LDZ, RWORK, M, WORK, N,
$ RWORK( M*M+1 ) )
CALL ZLACPY( 'A', N, M, WORK, N, Z( 1, START ), LDZ )
IF( INFO.GT.0 ) THEN
INFO = START*( N+1 ) + FINISH
GO TO 70
END IF
END IF
*
START = FINISH + 1
GO TO 30
END IF
*
* endwhile
*
* If the problem split any number of times, then the eigenvalues
* will not be properly ordered. Here we permute the eigenvalues
* (and the associated eigenvectors) into ascending order.
*
IF( M.NE.N ) THEN
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 60 II = 2, N
I = II - 1
K = I
P = D( I )
DO 50 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
50 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
60 CONTINUE
END IF
END IF
*
70 CONTINUE
WORK( 1 ) = LWMIN
RWORK( 1 ) = LRWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of ZSTEDC
*
END
SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK,
$ IWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), RWORK( * )
COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * )
* ..
*
* Purpose
* =======
*
* Using the divide and conquer method, ZLAED0 computes all eigenvalues
* of a symmetric tridiagonal matrix which is one diagonal block of
* those from reducing a dense or band Hermitian matrix and
* corresponding eigenvectors of the dense or band matrix.
*
* Arguments
* =========
*
* QSIZ (input) INTEGER
* The dimension of the unitary matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the diagonal elements of the tridiagonal matrix.
* On exit, the eigenvalues in ascending order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the off-diagonal elements of the tridiagonal matrix.
* On exit, E has been destroyed.
*
* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)
* On entry, Q must contain an QSIZ x N matrix whose columns
* unitarily orthonormal. It is a part of the unitary matrix
* that reduces the full dense Hermitian matrix to a
* (reducible) symmetric tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* IWORK (workspace) INTEGER array,
* the dimension of IWORK must be at least
* 6 + 6*N + 5*N*lg N
* ( lg( N ) = smallest integer k
* such that 2^k >= N )
*
* RWORK (workspace) DOUBLE PRECISION array,
* dimension (1 + 3*N + 2*N*lg N + 3*N**2)
* ( lg( N ) = smallest integer k
* such that 2^k >= N )
*
* QSTORE (workspace) COMPLEX*16 array, dimension (LDQS, N)
* Used to store parts of
* the eigenvector matrix when the updating matrix multiplies
* take place.
*
* LDQS (input) INTEGER
* The leading dimension of the array QSTORE.
* LDQS >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an eigenvalue while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through mod(INFO,N+1).
*
* =====================================================================
*
* Warning: N could be as big as QSIZ!
*
* .. Parameters ..
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.D+0 )
* ..
* .. Local Scalars ..
INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
$ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
$ J, K, LGN, LL, MATSIZ, MSD2, SMLSIZ, SMM1,
$ SPM1, SPM2, SUBMAT, SUBPBS, TLVLS
DOUBLE PRECISION TEMP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSTEQR, XERBLA, ZCOPY, ZLACRM, ZLAED7
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN
* INFO = -1
* ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) )
* $ THEN
IF( QSIZ.LT.MAX( 0, N ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLAED0', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
SMLSIZ = ILAENV( 9, 'ZLAED0', ' ', 0, 0, 0, 0 )
*
* Determine the size and placement of the submatrices, and save in
* the leading elements of IWORK.
*
IWORK( 1 ) = N
SUBPBS = 1
TLVLS = 0
10 CONTINUE
IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
DO 20 J = SUBPBS, 1, -1
IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
IWORK( 2*J-1 ) = IWORK( J ) / 2
20 CONTINUE
TLVLS = TLVLS + 1
SUBPBS = 2*SUBPBS
GO TO 10
END IF
DO 30 J = 2, SUBPBS
IWORK( J ) = IWORK( J ) + IWORK( J-1 )
30 CONTINUE
*
* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
* using rank-1 modifications (cuts).
*
SPM1 = SUBPBS - 1
DO 40 I = 1, SPM1
SUBMAT = IWORK( I ) + 1
SMM1 = SUBMAT - 1
D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
40 CONTINUE
*
INDXQ = 4*N + 3
*
* Set up workspaces for eigenvalues only/accumulate new vectors
* routine
*
TEMP = LOG( DBLE( N ) ) / LOG( TWO )
LGN = INT( TEMP )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IPRMPT = INDXQ + N + 1
IPERM = IPRMPT + N*LGN
IQPTR = IPERM + N*LGN
IGIVPT = IQPTR + N + 2
IGIVCL = IGIVPT + N*LGN
*
IGIVNM = 1
IQ = IGIVNM + 2*N*LGN
IWREM = IQ + N**2 + 1
* Initialize pointers
DO 50 I = 0, SUBPBS
IWORK( IPRMPT+I ) = 1
IWORK( IGIVPT+I ) = 1
50 CONTINUE
IWORK( IQPTR ) = 1
*
* Solve each submatrix eigenproblem at the bottom of the divide and
* conquer tree.
*
CURR = 0
DO 70 I = 0, SPM1
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 1 )
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+1 ) - IWORK( I )
END IF
LL = IQ - 1 + IWORK( IQPTR+CURR )
CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ RWORK( LL ), MATSIZ, RWORK, INFO )
CALL ZLACRM( QSIZ, MATSIZ, Q( 1, SUBMAT ), LDQ, RWORK( LL ),
$ MATSIZ, QSTORE( 1, SUBMAT ), LDQS,
$ RWORK( IWREM ) )
IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
CURR = CURR + 1
IF( INFO.GT.0 ) THEN
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
RETURN
END IF
K = 1
DO 60 J = SUBMAT, IWORK( I+1 )
IWORK( INDXQ+J ) = K
K = K + 1
60 CONTINUE
70 CONTINUE
*
* Successively merge eigensystems of adjacent submatrices
* into eigensystem for the corresponding larger matrix.
*
* while ( SUBPBS > 1 )
*
CURLVL = 1
80 CONTINUE
IF( SUBPBS.GT.1 ) THEN
SPM2 = SUBPBS - 2
DO 90 I = 0, SPM2, 2
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 2 )
MSD2 = IWORK( 1 )
CURPRB = 0
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+2 ) - IWORK( I )
MSD2 = MATSIZ / 2
CURPRB = CURPRB + 1
END IF
*
* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
* into an eigensystem of size MATSIZ. ZLAED7 handles the case
* when the eigenvectors of a full or band Hermitian matrix (which
* was reduced to tridiagonal form) are desired.
*
* I am free to use Q as a valuable working space until Loop 150.
*
CALL ZLAED7( MATSIZ, MSD2, QSIZ, TLVLS, CURLVL, CURPRB,
$ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
$ E( SUBMAT+MSD2-1 ), IWORK( INDXQ+SUBMAT ),
$ RWORK( IQ ), IWORK( IQPTR ), IWORK( IPRMPT ),
$ IWORK( IPERM ), IWORK( IGIVPT ),
$ IWORK( IGIVCL ), RWORK( IGIVNM ),
$ Q( 1, SUBMAT ), RWORK( IWREM ),
$ IWORK( SUBPBS+1 ), INFO )
IF( INFO.GT.0 ) THEN
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
RETURN
END IF
IWORK( I / 2+1 ) = IWORK( I+2 )
90 CONTINUE
SUBPBS = SUBPBS / 2
CURLVL = CURLVL + 1
GO TO 80
END IF
*
* end while
*
* Re-merge the eigenvalues/vectors which were deflated at the final
* merge step.
*
DO 100 I = 1, N
J = IWORK( INDXQ+I )
RWORK( I ) = D( J )
CALL ZCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
100 CONTINUE
CALL DCOPY( N, RWORK, 1, D, 1 )
*
RETURN
*
* End of ZLAED0
*
END
SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
$ LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM,
$ GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ,
$ TLVLS
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
$ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
DOUBLE PRECISION D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * )
COMPLEX*16 Q( LDQ, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZLAED7 computes the updated eigensystem of a diagonal
* matrix after modification by a rank-one symmetric matrix. This
* routine is used only for the eigenproblem which requires all
* eigenvalues and optionally eigenvectors of a dense or banded
* Hermitian matrix that has been reduced to tridiagonal form.
*
* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
* where Z = Q'u, u is a vector of length N with ones in the
* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*
* The eigenvectors of the original matrix are stored in Q, and the
* eigenvalues are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple eigenvalues or if there is a zero in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine DLAED2.
*
* The second stage consists of calculating the updated
* eigenvalues. This is done by finding the roots of the secular
* equation via the routine DLAED4 (as called by SLAED3).
* This routine also calculates the eigenvectors of the current
* problem.
*
* The final stage consists of computing the updated eigenvectors
* directly using the updated eigenvalues. The eigenvectors for
* the current problem are multiplied with the eigenvectors from
* the overall problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* CUTPNT (input) INTEGER
* Contains the location of the last eigenvalue in the leading
* sub-matrix. min(1,N) <= CUTPNT <= N.
*
* QSIZ (input) INTEGER
* The dimension of the unitary matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N.
*
* TLVLS (input) INTEGER
* The total number of merging levels in the overall divide and
* conquer tree.
*
* CURLVL (input) INTEGER
* The current level in the overall merge routine,
* 0 <= curlvl <= tlvls.
*
* CURPBM (input) INTEGER
* The current problem in the current level in the overall
* merge routine (counting from upper left to lower right).
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the eigenvalues of the rank-1-perturbed matrix.
* On exit, the eigenvalues of the repaired matrix.
*
* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)
* On entry, the eigenvectors of the rank-1-perturbed matrix.
* On exit, the eigenvectors of the repaired tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* RHO (input) DOUBLE PRECISION
* Contains the subdiagonal element used to create the rank-1
* modification.
*
* INDXQ (output) INTEGER array, dimension (N)
* This contains the permutation which will reintegrate the
* subproblem just solved back into sorted order,
* ie. D( INDXQ( I = 1, N ) ) will be in ascending order.
*
* IWORK (workspace) INTEGER array, dimension (4*N)
*
* RWORK (workspace) DOUBLE PRECISION array,
* dimension (3*N+2*QSIZ*N)
*
* WORK (workspace) COMPLEX*16 array, dimension (QSIZ*N)
*
* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)
* Stores eigenvectors of submatrices encountered during
* divide and conquer, packed together. QPTR points to
* beginning of the submatrices.
*
* QPTR (input/output) INTEGER array, dimension (N+2)
* List of indices pointing to beginning of submatrices stored
* in QSTORE. The submatrices are numbered starting at the
* bottom left of the divide and conquer tree, from left to
* right and bottom to top.
*
* PRMPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in PERM a
* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
* indicates the size of the permutation and also the size of
* the full, non-deflated problem.
*
* PERM (input) INTEGER array, dimension (N lg N)
* Contains the permutations (from deflation and sorting) to be
* applied to each eigenblock.
*
* GIVPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in GIVCOL a
* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
* indicates the number of Givens rotations.
*
* GIVCOL (input) INTEGER array, dimension (2, N lg N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER COLTYP, CURR, I, IDLMDA, INDX,
$ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR
* ..
* .. External Subroutines ..
EXTERNAL DLAED9, DLAEDA, DLAMRG, XERBLA, ZLACRM, ZLAED8
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
* IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
* INFO = -1
* ELSE IF( N.LT.0 ) THEN
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
INFO = -2
ELSE IF( QSIZ.LT.N ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLAED7', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in DLAED2 and SLAED3.
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ = IW + N
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
PTR = 1 + 2**TLVLS
DO 10 I = 1, CURLVL - 1
PTR = PTR + 2**( TLVLS-I )
10 CONTINUE
CURR = PTR + CURPBM
CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, QSTORE, QPTR, RWORK( IZ ),
$ RWORK( IZ+N ), INFO )
*
* When solving the final problem, we no longer need the stored data,
* so we will overwrite the data from this level onto the previously
* used storage space.
*
IF( CURLVL.EQ.TLVLS ) THEN
QPTR( CURR ) = 1
PRMPTR( CURR ) = 1
GIVPTR( CURR ) = 1
END IF
*
* Sort and Deflate eigenvalues.
*
CALL ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, RWORK( IZ ),
$ RWORK( IDLMDA ), WORK, QSIZ, RWORK( IW ),
$ IWORK( INDXP ), IWORK( INDX ), INDXQ,
$ PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
$ GIVCOL( 1, GIVPTR( CURR ) ),
$ GIVNUM( 1, GIVPTR( CURR ) ), INFO )
PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
CALL DLAED9( K, 1, K, N, D, RWORK( IQ ), K, RHO,
$ RWORK( IDLMDA ), RWORK( IW ),
$ QSTORE( QPTR( CURR ) ), K, INFO )
CALL ZLACRM( QSIZ, K, WORK, QSIZ, QSTORE( QPTR( CURR ) ), K, Q,
$ LDQ, RWORK( IQ ) )
QPTR( CURR+1 ) = QPTR( CURR ) + K**2
IF( INFO.NE.0 ) THEN
RETURN
END IF
*
* Prepare the INDXQ sorting premutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
QPTR( CURR+1 ) = QPTR( CURR )
DO 20 I = 1, N
INDXQ( I ) = I
20 CONTINUE
END IF
*
RETURN
*
* End of ZLAED7
*
END
SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA,
$ Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR,
$ GIVCOL, GIVNUM, INFO )
*
* -- LAPACK routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
*
* .. Scalar Arguments ..
INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
$ INDXQ( * ), PERM( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ),
$ Z( * )
COMPLEX*16 Q( LDQ, * ), Q2( LDQ2, * )
* ..
*
* Purpose
* =======
*
* ZLAED8 merges the two sets of eigenvalues together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* eigenvalues are close together or if there is a tiny element in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* Arguments
* =========
*
* K (output) INTEGER
* Contains the number of non-deflated eigenvalues.
* This is the order of the related secular equation.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* QSIZ (input) INTEGER
* The dimension of the unitary matrix used to reduce
* the dense or band matrix to tridiagonal form.
* QSIZ >= N if ICOMPQ = 1.
*
* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)
* On entry, Q contains the eigenvectors of the partially solved
* system which has been previously updated in matrix
* multiplies with other partially solved eigensystems.
* On exit, Q contains the trailing (N-K) updated eigenvectors
* (those which were deflated) in its last N-K columns.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max( 1, N ).
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, D contains the eigenvalues of the two submatrices to
* be combined. On exit, D contains the trailing (N-K) updated
* eigenvalues (those which were deflated) sorted into increasing
* order.
*
* RHO (input/output) DOUBLE PRECISION
* Contains the off diagonal element associated with the rank-1
* cut which originally split the two submatrices which are now
* being recombined. RHO is modified during the computation to
* the value required by DLAED3.
*
* CUTPNT (input) INTEGER
* Contains the location of the last eigenvalue in the leading
* sub-matrix. MIN(1,N) <= CUTPNT <= N.
*
* Z (input) DOUBLE PRECISION array, dimension (N)
* On input this vector contains the updating vector (the last
* row of the first sub-eigenvector matrix and the first row of
* the second sub-eigenvector matrix). The contents of Z are
* destroyed during the updating process.
*
* DLAMDA (output) DOUBLE PRECISION array, dimension (N)
* Contains a copy of the first K eigenvalues which will be used
* by DLAED3 to form the secular equation.
*
* Q2 (output) COMPLEX*16 array, dimension (LDQ2,N)
* If ICOMPQ = 0, Q2 is not referenced. Otherwise,
* Contains a copy of the first K eigenvectors which will be used
* by DLAED7 in a matrix multiply (DGEMM) to update the new
* eigenvectors.
*
* LDQ2 (input) INTEGER
* The leading dimension of the array Q2. LDQ2 >= max( 1, N ).
*
* W (output) DOUBLE PRECISION array, dimension (N)
* This will hold the first k values of the final
* deflation-altered z-vector and will be passed to DLAED3.
*
* INDXP (workspace) INTEGER array, dimension (N)
* This will contain the permutation used to place deflated
* values of D at the end of the array. On output INDXP(1:K)
* points to the nondeflated D-values and INDXP(K+1:N)
* points to the deflated eigenvalues.
*
* INDX (workspace) INTEGER array, dimension (N)
* This will contain the permutation used to sort the contents of
* D into ascending order.
*
* INDXQ (input) INTEGER array, dimension (N)
* This contains the permutation which separately sorts the two
* sub-problems in D into ascending order. Note that elements in
* the second half of this permutation must first have CUTPNT
* added to their values in order to be accurate.
*
* PERM (output) INTEGER array, dimension (N)
* Contains the permutations (from deflation and sorting) to be
* applied to each eigenblock.
*
* GIVPTR (output) INTEGER
* Contains the number of Givens rotations which took place in
* this subproblem.
*
* GIVCOL (output) INTEGER array, dimension (2, N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, EIGHT = 8.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
DOUBLE PRECISION C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL IDAMAX, DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAMRG, DSCAL, XERBLA, ZCOPY, ZDROT,
$ ZLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( QSIZ.LT.N ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
INFO = -8
ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLAED8', -INFO )
RETURN
END IF
*
* Need to initialize GIVPTR to O here in case of quick exit
* to prevent an unspecified code behavior (usually sigfault)
* when IWORK array on entry to *stedc is not zeroed
* (or at least some IWORK entries which used in *laed7 for GIVPTR).
*
GIVPTR = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N1 = CUTPNT
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1
*
T = ONE / SQRT( TWO )
DO 10 J = 1, N
INDX( J ) = J
10 CONTINUE
CALL DSCAL( N, T, Z, 1 )
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 20 I = CUTPNT + 1, N
INDXQ( I ) = INDXQ( I ) + CUTPNT
20 CONTINUE
DO 30 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
W( I ) = Z( INDXQ( I ) )
30 CONTINUE
I = 1
J = CUTPNT + 1
CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
DO 40 I = 1, N
D( I ) = DLAMDA( INDX( I ) )
Z( I ) = W( INDX( I ) )
40 CONTINUE
*
* Calculate the allowable deflation tolerance
*
IMAX = IDAMAX( N, Z, 1 )
JMAX = IDAMAX( N, D, 1 )
EPS = DLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*ABS( D( JMAX ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* -- except to reorganize Q so that its columns correspond with the
* elements in D.
*
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
DO 50 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
50 CONTINUE
CALL ZLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), LDQ )
RETURN
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
K = 0
K2 = N + 1
DO 60 J = 1, N
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
IF( J.EQ.N )
$ GO TO 100
ELSE
JLAM = J
GO TO 70
END IF
60 CONTINUE
70 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 90
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( JLAM )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = DLAPY2( C, S )
T = D( J ) - D( JLAM )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( J ) = TAU
Z( JLAM ) = ZERO
*
* Record the appropriate Givens rotation
*
GIVPTR = GIVPTR + 1
GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
GIVNUM( 1, GIVPTR ) = C
GIVNUM( 2, GIVPTR ) = S
CALL ZDROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
$ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
T = D( JLAM )*C*C + D( J )*S*S
D( J ) = D( JLAM )*S*S + D( J )*C*C
D( JLAM ) = T
K2 = K2 - 1
I = 1
80 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = JLAM
I = I + 1
GO TO 80
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
JLAM = J
ELSE
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
JLAM = J
END IF
END IF
GO TO 70
90 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
*
100 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
DO 110 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
110 CONTINUE
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
IF( K.LT.N ) THEN
CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
CALL ZLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, Q( 1, K+1 ),
$ LDQ )
END IF
*
RETURN
*
* End of ZLAED8
*
END
SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), RWORK( * )
COMPLEX*16 A( LDA, * ), C( LDC, * )
* ..
*
* Purpose
* =======
*
* ZLACRM performs a very simple matrix-matrix multiplication:
* C := A * B,
* where A is M by N and complex; B is N by N and real;
* C is M by N and complex.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A and of the matrix C.
* M >= 0.
*
* N (input) INTEGER
* The number of columns and rows of the matrix B and
* the number of columns of the matrix C.
* N >= 0.
*
* A (input) COMPLEX*16 array, dimension (LDA, N)
* A contains the M by N matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >=max(1,M).
*
* B (input) DOUBLE PRECISION array, dimension (LDB, N)
* B contains the N by N matrix B.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >=max(1,N).
*
* C (input) COMPLEX*16 array, dimension (LDC, N)
* C contains the M by N matrix C.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >=max(1,N).
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (2*M*N)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DIMAG
* ..
* .. External Subroutines ..
EXTERNAL DGEMM
* ..
* .. Executable Statements ..
*
* Quick return if possible.
*
IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
$ RETURN
*
DO 20 J = 1, N
DO 10 I = 1, M
RWORK( ( J-1 )*M+I ) = DBLE( A( I, J ) )
10 CONTINUE
20 CONTINUE
*
L = M*N + 1
CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO,
$ RWORK( L ), M )
DO 40 J = 1, N
DO 30 I = 1, M
C( I, J ) = RWORK( L+( J-1 )*M+I-1 )
30 CONTINUE
40 CONTINUE
*
DO 60 J = 1, N
DO 50 I = 1, M
RWORK( ( J-1 )*M+I ) = DIMAG( A( I, J ) )
50 CONTINUE
60 CONTINUE
CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO,
$ RWORK( L ), M )
DO 80 J = 1, N
DO 70 I = 1, M
C( I, J ) = DCMPLX( DBLE( C( I, J ) ),
$ RWORK( L+( J-1 )*M+I-1 ) )
70 CONTINUE
80 CONTINUE
*
RETURN
*
* End of ZLACRM
*
END
SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a
* complex Hermitian matrix in packed storage.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the Hermitian matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, AP is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the diagonal
* and first superdiagonal of the tridiagonal matrix T overwrite
* the corresponding elements of A, and if UPLO = 'L', the
* diagonal and first subdiagonal of T overwrite the
* corresponding elements of A.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) COMPLEX*16 array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of an intermediate tridiagonal
* form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL WANTZ
INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWRK,
$ ISCALE
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANHP
EXTERNAL LSAME, DLAMCH, ZLANHP
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSTERF, XERBLA, ZDSCAL, ZHPTRD, ZSTEQR,
$ ZUPGTR
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPEV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = AP( 1 )
RWORK( 1 ) = 1
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = ZLANHP( 'M', UPLO, N, AP, RWORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
END IF
*
* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form.
*
INDE = 1
INDTAU = 1
CALL ZHPTRD( UPLO, N, AP, W, RWORK( INDE ), WORK( INDTAU ),
$ IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* ZUPGTR to generate the orthogonal matrix, then call ZSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, RWORK( INDE ), INFO )
ELSE
INDWRK = INDTAU + N
CALL ZUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
INDRWK = INDE + N
CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ,
$ RWORK( INDRWK ), INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
RETURN
*
* End of ZHPEV
*
END
SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK,
$ RWORK, LRWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK,
$ M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* ZHEEVR computes selected eigenvalues and, optionally, eigenvectors
* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
* be selected by specifying either a range of values or a range of
* indices for the desired eigenvalues.
*
* ZHEEVR first reduces the matrix A to tridiagonal form T with a call
* to ZHETRD. Then, whenever possible, ZHEEVR calls ZSTEMR to compute
* eigenspectrum using Relatively Robust Representations. ZSTEMR
* computes eigenvalues by the dqds algorithm, while orthogonal
* eigenvectors are computed from various "good" L D L^T representations
* (also known as Relatively Robust Representations). Gram-Schmidt
* orthogonalization is avoided as far as possible. More specifically,
* the various steps of the algorithm are as follows.
*
* For each unreduced block (submatrix) of T,
* (a) Compute T - sigma I = L D L^T, so that L and D
* define all the wanted eigenvalues to high relative accuracy.
* This means that small relative changes in the entries of D and L
* cause only small relative changes in the eigenvalues and
* eigenvectors. The standard (unfactored) representation of the
* tridiagonal matrix T does not have this property in general.
* (b) Compute the eigenvalues to suitable accuracy.
* If the eigenvectors are desired, the algorithm attains full
* accuracy of the computed eigenvalues only right before
* the corresponding vectors have to be computed, see steps c) and d).
* (c) For each cluster of close eigenvalues, select a new
* shift close to the cluster, find a new factorization, and refine
* the shifted eigenvalues to suitable accuracy.
* (d) For each eigenvalue with a large enough relative separation compute
* the corresponding eigenvector by forming a rank revealing twisted
* factorization. Go back to (c) for any clusters that remain.
*
* The desired accuracy of the output can be specified by the input
* parameter ABSTOL.
*
* For more details, see DSTEMR's documentation and:
* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
* 2004. Also LAPACK Working Note 154.
* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
* tridiagonal eigenvalue/eigenvector problem",
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
*
* Note 1 : ZHEEVR calls ZSTEMR when the full spectrum is requested
* on machines which conform to the ieee-754 floating point standard.
* ZHEEVR calls DSTEBZ and ZSTEIN on non-ieee machines and
* when partial spectrum requests are made.
*
* Normal execution of ZSTEMR may create NaNs and infinities and
* hence may abort due to a floating point exception in environments
* which do not handle NaNs and infinities in the ieee standard default
* manner.
*
* 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.
********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
********** ZSTEIN are called
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) COMPLEX*16 array, dimension (LDA, N)
* On entry, the Hermitian matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of A contains the
* upper triangular part of the matrix A. If UPLO = 'L',
* the leading N-by-N lower triangular part of A contains
* the lower triangular part of the matrix A.
* On exit, 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
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* 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.
*
* If high relative accuracy is important, set ABSTOL to
* DLAMCH( 'Safe minimum' ). Doing so will guarantee that
* eigenvalues are computed to high relative accuracy when
* possible in future releases. The current code does not
* make any guarantees about high relative accuracy, but
* furutre releases will. See J. Barlow and J. Demmel,
* "Computing Accurate Eigensystems of Scaled Diagonally
* Dominant Matrices", LAPACK Working Note #7, for a discussion
* of which matrices define their eigenvalues to high relative
* accuracy.
*
* 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)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) COMPLEX*16 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 A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* 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).
*
* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ).
********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
*
* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length of the array WORK. LWORK >= max(1,2*N).
* For optimal efficiency, LWORK >= (NB+1)*N,
* where NB is the max of the blocksize for ZHETRD and for
* ZUNMTR as returned by ILAENV.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK, RWORK and
* IWORK arrays, returns these values as the first entries of
* the WORK, RWORK and IWORK arrays, and no error message
* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*
* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
* On exit, if INFO = 0, RWORK(1) returns the optimal
* (and minimal) LRWORK.
*
* LRWORK (input) INTEGER
* The length of the array RWORK. LRWORK >= max(1,24*N).
*
* If LRWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK, RWORK
* and IWORK arrays, returns these values as the first entries
* of the WORK, RWORK and IWORK arrays, and no error message
* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal
* (and minimal) LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= max(1,10*N).
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK, RWORK
* and IWORK arrays, returns these values as the first entries
* of the WORK, RWORK and IWORK arrays, and no error message
* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: Internal error
*
* Further Details
* ===============
*
* Based on contributions by
* Inderjit Dhillon, IBM Almaden, USA
* Osni Marques, LBNL/NERSC, USA
* Ken Stanley, Computer Science Division, University of
* California at Berkeley, USA
* Jason Riedy, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
$ WANTZ, TRYRAC
CHARACTER ORDER
INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP,
$ INDIWO, INDRD, INDRDD, INDRE, INDREE, INDRWK,
$ INDTAU, INDWK, INDWKN, ISCALE, ITMP1, J, JJ,
$ LIWMIN, LLWORK, LLRWORK, LLWRKN, LRWMIN,
$ LWKOPT, LWMIN, NB, NSPLIT
DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANSY
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANSY
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL,
$ ZHETRD, ZSTEMR, ZSTEIN, ZSWAP, ZUNMTR
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
IEEEOK = ILAENV( 10, 'ZHEEVR', 'N', 1, 2, 3, 4 )
*
LOWER = LSAME( UPLO, 'L' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LRWORK.EQ.-1 ) .OR.
$ ( LIWORK.EQ.-1 ) )
*
LRWMIN = MAX( 1, 24*N )
LIWMIN = MAX( 1, 10*N )
LWMIN = MAX( 1, 2*N )
*
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 ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -8
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -10
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -15
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
NB = MAX( NB, ILAENV( 1, 'ZUNMTR', UPLO, N, -1, -1, -1 ) )
LWKOPT = MAX( ( NB+1 )*N, LWMIN )
WORK( 1 ) = LWKOPT
RWORK( 1 ) = LRWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -18
ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
INFO = -20
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -22
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHEEVR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
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 ) = 2
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = DBLE( A( 1, 1 ) )
ELSE
IF( VL.LT.DBLE( A( 1, 1 ) ) .AND. VU.GE.DBLE( A( 1, 1 ) ) )
$ THEN
M = 1
W( 1 ) = DBLE( A( 1, 1 ) )
END IF
END IF
IF( WANTZ ) THEN
Z( 1, 1 ) = ONE
ISUPPZ( 1 ) = 1
ISUPPZ( 2 ) = 1
END IF
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 = ZLANSY( 'M', UPLO, N, A, LDA, RWORK )
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 ZDSCAL( N-J+1, SIGMA, A( J, J ), 1 )
10 CONTINUE
ELSE
DO 20 J = 1, N
CALL ZDSCAL( 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
* Initialize indices into workspaces. Note: The IWORK indices are
* used only if DSTERF or ZSTEMR fail.
* WORK(INDTAU:INDTAU+N-1) stores the complex scalar factors of the
* elementary reflectors used in ZHETRD.
INDTAU = 1
* INDWK is the starting offset of the remaining complex workspace,
* and LLWORK is the remaining complex workspace size.
INDWK = INDTAU + N
LLWORK = LWORK - INDWK + 1
* RWORK(INDRD:INDRD+N-1) stores the real tridiagonal's diagonal
* entries.
INDRD = 1
* RWORK(INDRE:INDRE+N-1) stores the off-diagonal entries of the
* tridiagonal matrix from ZHETRD.
INDRE = INDRD + N
* RWORK(INDRDD:INDRDD+N-1) is a copy of the diagonal entries over
* -written by ZSTEMR (the DSTERF path copies the diagonal to W).
INDRDD = INDRE + N
* RWORK(INDREE:INDREE+N-1) is a copy of the off-diagonal entries over
* -written while computing the eigenvalues in DSTERF and ZSTEMR.
INDREE = INDRDD + N
* INDRWK is the starting offset of the left-over real workspace, and
* LLRWORK is the remaining workspace size.
INDRWK = INDREE + N
LLRWORK = LRWORK - INDRWK + 1
* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and
* stores the block indices of each of the M<=N eigenvalues.
INDIBL = 1
* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and
* stores the starting and finishing indices of each block.
INDISP = INDIBL + N
* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
* that corresponding to eigenvectors that fail to converge in
* DSTEIN. This information is discarded; if any fail, the driver
* returns INFO > 0.
INDIFL = INDISP + N
* INDIWO is the offset of the remaining integer workspace.
INDIWO = INDISP + N
*
* Call ZHETRD to reduce Hermitian matrix to tridiagonal form.
*
CALL ZHETRD( UPLO, N, A, LDA, RWORK( INDRD ), RWORK( INDRE ),
$ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO )
*
* If all eigenvalues are desired
* then call DSTERF or ZSTEMR and ZUNMTR.
*
TEST = .FALSE.
IF( INDEIG ) THEN
IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
TEST = .TRUE.
END IF
END IF
IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN
IF( .NOT.WANTZ ) THEN
CALL DCOPY( N, RWORK( INDRD ), 1, W, 1 )
CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 )
CALL DSTERF( N, W, RWORK( INDREE ), INFO )
ELSE
CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 )
CALL DCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 )
*
IF (ABSTOL .LE. TWO*N*EPS) THEN
TRYRAC = .TRUE.
ELSE
TRYRAC = .FALSE.
END IF
CALL ZSTEMR( JOBZ, 'A', N, RWORK( INDRDD ),
$ RWORK( INDREE ), VL, VU, IL, IU, M, W,
$ Z, LDZ, N, ISUPPZ, TRYRAC,
$ RWORK( INDRWK ), LLRWORK,
$ IWORK, LIWORK, INFO )
*
* Apply unitary matrix used in reduction to tridiagonal
* form to eigenvectors returned by ZSTEIN.
*
IF( WANTZ .AND. INFO.EQ.0 ) THEN
INDWKN = INDWK
LLWRKN = LWORK - INDWKN + 1
CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA,
$ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ),
$ LLWRKN, IINFO )
END IF
END IF
*
*
IF( INFO.EQ.0 ) THEN
M = N
GO TO 30
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN.
* Also call DSTEBZ and ZSTEIN if ZSTEMR fails.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ RWORK( INDRD ), RWORK( INDRE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL ZSTEIN( N, RWORK( INDRD ), RWORK( INDRE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ RWORK( INDRWK ), IWORK( INDIWO ), IWORK( INDIFL ),
$ INFO )
*
* Apply unitary matrix used in reduction to tridiagonal
* form to eigenvectors returned by ZSTEIN.
*
INDWKN = INDWK
LLWRKN = LWORK - INDWKN + 1
CALL ZUNMTR( '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.
*
30 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 50 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 40 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
40 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 ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
END IF
50 CONTINUE
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
RWORK( 1 ) = LRWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of ZHEEVR
*
END
SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK,
$ IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDZ, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* ZHPEVX computes selected eigenvalues and, optionally, eigenvectors
* of a complex Hermitian matrix A in packed storage.
* Eigenvalues/vectors 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.
*
* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the Hermitian matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, AP is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the diagonal
* and first superdiagonal of the tridiagonal matrix T overwrite
* the corresponding elements of A, and if UPLO = 'L', the
* diagonal and first subdiagonal of T overwrite the
* corresponding elements of A.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* 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 AP to tridiagonal form.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
* If this routine returns with INFO>0, indicating that some
* eigenvectors did not converge, try setting ABSTOL to
* 2*DLAMCH('S').
*
* 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)
* If INFO = 0, the selected eigenvalues in ascending order.
*
* Z (output) COMPLEX*16 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 A
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* 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) COMPLEX*16 array, dimension (2*N)
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)
*
* 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 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ
CHARACTER ORDER
INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
$ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE,
$ ITMP1, J, JJ, NSPLIT
DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANHP
EXTERNAL LSAME, DLAMCH, ZLANHP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL,
$ ZHPTRD, ZSTEIN, ZSTEQR, ZSWAP, ZUPGTR, ZUPMTR
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
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.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
$ THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -7
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -9
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
$ INFO = -14
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPEVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = AP( 1 )
ELSE
IF( VL.LT.DBLE( AP( 1 ) ) .AND. VU.GE.DBLE( AP( 1 ) ) ) THEN
M = 1
W( 1 ) = AP( 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = CONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = 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
ELSE
VLL = ZERO
VUU = ZERO
END IF
ANRM = ZLANHP( 'M', UPLO, N, AP, RWORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form.
*
INDD = 1
INDE = INDD + N
INDRWK = INDE + N
INDTAU = 1
INDWRK = INDTAU + N
CALL ZHPTRD( UPLO, N, AP, RWORK( INDD ), RWORK( INDE ),
$ WORK( INDTAU ), IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal
* to zero, then call DSTERF or ZUPGTR and ZSTEQR. If this fails
* for some eigenvalue, then try DSTEBZ.
*
TEST = .FALSE.
IF (INDEIG) THEN
IF (IL.EQ.1 .AND. IU.EQ.N) THEN
TEST = .TRUE.
END IF
END IF
IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
CALL DCOPY( N, RWORK( INDD ), 1, W, 1 )
INDEE = INDRWK + 2*N
IF( .NOT.WANTZ ) THEN
CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
CALL DSTERF( N, W, RWORK( INDEE ), INFO )
ELSE
CALL ZUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ,
$ RWORK( INDRWK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 10 I = 1, N
IFAIL( I ) = 0
10 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 20
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWK = INDISP + N
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
$ IWORK( INDIWK ), INFO )
*
IF( WANTZ ) THEN
CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO )
*
* Apply unitary matrix used in reduction to tridiagonal
* form to eigenvectors returned by ZSTEIN.
*
INDWRK = INDTAU + N
CALL ZUPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
20 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 40 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 30 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
30 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 ZSWAP( 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
40 CONTINUE
END IF
*
RETURN
*
* End of ZHPEVX
*
END
SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DGETRI computes the inverse of a matrix using the LU factorization
* computed by DGETRF.
*
* This method inverts U and then computes inv(A) by solving the system
* inv(A)*L = inv(U) for inv(A).
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the factors L and U from the factorization
* A = P*L*U as computed by DGETRF.
* On exit, if INFO = 0, the inverse of the original matrix A.
*
* 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).
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,N).
* For optimal performance LWORK >= N*NB, where NB is
* the optimal blocksize returned by ILAENV.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* 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 matrix is
* singular and its inverse could not be computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
$ NBMIN, NN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -3
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGETRI', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form inv(U). If INFO > 0 from DTRTRI, then U is singular,
* and the inverse is not computed.
*
CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
IF( INFO.GT.0 )
$ RETURN
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = MAX( LDWORK*NB, 1 )
IF( LWORK.LT.IWS ) THEN
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )
END IF
ELSE
IWS = N
END IF
*
* Solve the equation inv(A)*L = inv(U) for inv(A).
*
IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
*
* Use unblocked code.
*
DO 20 J = N, 1, -1
*
* Copy current column of L to WORK and replace with zeros.
*
DO 10 I = J + 1, N
WORK( I ) = A( I, J )
A( I, J ) = ZERO
10 CONTINUE
*
* Compute current column of inv(A).
*
IF( J.LT.N )
$ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
$ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
20 CONTINUE
ELSE
*
* Use blocked code.
*
NN = ( ( N-1 ) / NB )*NB + 1
DO 50 J = NN, 1, -NB
JB = MIN( NB, N-J+1 )
*
* Copy current block column of L to WORK and replace with
* zeros.
*
DO 40 JJ = J, J + JB - 1
DO 30 I = JJ + 1, N
WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
A( I, JJ ) = ZERO
30 CONTINUE
40 CONTINUE
*
* Compute current block column of inv(A).
*
IF( J+JB.LE.N )
$ CALL DGEMM( 'No transpose', 'No transpose', N, JB,
$ N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
$ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
$ ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
50 CONTINUE
END IF
*
* Apply column interchanges.
*
DO 60 J = N - 1, 1, -1
JP = IPIV( J )
IF( JP.NE.J )
$ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
60 CONTINUE
*
WORK( 1 ) = IWS
RETURN
*
* End of DGETRI
*
END
SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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
SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSYTRF computes the factorization of a real symmetric matrix A using
* the Bunch-Kaufman diagonal pivoting method. The form of the
* factorization is
*
* A = U*D*U**T or A = L*D*L**T
*
* where U (or L) is a product of permutation and unit upper (lower)
* triangular matrices, 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
* = '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, 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/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The length of WORK. LWORK >=1. For best performance
* LWORK >= N*NB, where NB is the block size returned by ILAENV.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, D(i,i) 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 LQUERY, UPPER
INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, 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' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size
*
NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTRF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
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 ) = LWKOPT
RETURN
*
* End of DSYTRF
*
END
SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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**T or A = L*D*L**T 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**T;
* = 'L': Lower triangular, form is A = L*D*L**T.
*
* 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 = -i, the i-th argument had an illegal value
* > 0: if INFO = i, D(i,i) = 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
SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDA, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DSYEVD computes all eigenvalues and, optionally, eigenvectors of a
* real symmetric matrix A. If eigenvectors are desired, it uses a
* divide and conquer algorithm.
*
* The divide and conquer algorithm makes very mild assumptions about
* floating point arithmetic. It will work on machines with a guard
* digit in add/subtract, or on those binary machines without guard
* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
* Cray-2. It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Because of large use of BLAS of level 3, DSYEVD needs N**2 more
* workspace than DSYEVX.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) 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, if JOBZ = 'V', then if INFO = 0, A contains the
* orthonormal eigenvectors of the matrix A.
* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
* or the upper triangle (if UPLO='U') of A, including the
* diagonal, is destroyed.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* WORK (workspace/output) 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 N <= 1, LWORK must be at least 1.
* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.
* If JOBZ = 'V' and N > 1, LWORK must be at least
* 1 + 6*N + 2*N**2.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal sizes of the WORK and IWORK
* arrays, returns these values as the first entries of the WORK
* and IWORK arrays, and no error message related to LWORK or
* LIWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If N <= 1, LIWORK must be at least 1.
* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal sizes of the WORK and
* IWORK arrays, returns these values as the first entries of
* the WORK and IWORK arrays, and no error message related to
* LWORK or LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed
* to converge; i off-diagonal elements of an intermediate
* tridiagonal form did not converge to zero;
* if INFO = i and JOBZ = 'V', then the algorithm failed
* to compute an eigenvalue while working on the submatrix
* lying in rows and columns INFO/(N+1) through
* mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* Modified description of INFO. Sven, 16 Feb 05.
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
*
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE,
$ LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, DSTERF,
$ DSYTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LIWMIN = 1
LWMIN = 1
LOPT = LWMIN
LIOPT = LIWMIN
ELSE
IF( WANTZ ) THEN
LIWMIN = 3 + 5*N
LWMIN = 1 + 6*N + 2*N**2
ELSE
LIWMIN = 1
LWMIN = 2*N + 1
END IF
LOPT = MAX( LWMIN, 2*N +
$ ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) )
LIOPT = LIWMIN
END IF
WORK( 1 ) = LOPT
IWORK( 1 ) = LIOPT
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYEVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = A( 1, 1 )
IF( WANTZ )
$ A( 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 = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 )
$ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
*
* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
*
INDE = 1
INDTAU = INDE + N
INDWRK = INDTAU + N
LLWORK = LWORK - INDWRK + 1
INDWK2 = INDWRK + N*N
LLWRK2 = LWORK - INDWK2 + 1
*
CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
LOPT = 2*N + WORK( INDWRK )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
* tridiagonal matrix, then call DORMTR to multiply it by the
* Householder transformations stored in A.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
$ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
$ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
LOPT = MAX( LOPT, 1+6*N+2*N**2 )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 )
$ CALL DSCAL( N, ONE / SIGMA, W, 1 )
*
WORK( 1 ) = LOPT
IWORK( 1 ) = LIOPT
*
RETURN
*
* End of DSYEVD
*
END
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
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
*
* -- LAPACK auxiliary routine (version 3.2.1) --
*
* -- April 2009 --
*
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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.
*
* ILAENV returns an INTEGER
* if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC
* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value.
*
* 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 (DEPRECATED)
* = 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 method
* for nonsymmetric eigenvalue problems (DEPRECATED)
* = 9: maximum size of the subproblems at the bottom of the
* computation tree in the divide-and-conquer algorithm
* (used by xGELSD and xGESDD)
* =10: ieee NaN arithmetic can be trusted not to trap
* =11: infinity arithmetic can be trusted not to trap
* 12 <= ISPEC <= 16:
* xHSEQR or one of its subroutines,
* see IPARMQ for detailed explanation
*
* 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.
*
* 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 ..
INTEGER I, IC, IZ, NB, NBMIN, NX
LOGICAL CNAME, SNAME
CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6
* ..
* .. Intrinsic Functions ..
INTRINSIC CHAR, ICHAR, INT, MIN, REAL
* ..
* .. External Functions ..
INTEGER IEEECK, IPARMQ
EXTERNAL IEEECK, IPARMQ
* ..
* .. Executable Statements ..
*
GO TO ( 10, 10, 10, 80, 90, 100, 110, 120,
$ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC
*
* Invalid value for ISPEC
*
ILAENV = -1
RETURN
*
10 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 20 I = 2, 6
IC = ICHAR( SUBNAM( I: I ) )
IF( IC.GE.97 .AND. IC.LE.122 )
$ SUBNAM( I: I ) = CHAR( IC-32 )
20 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 30 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 )
30 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 40 I = 2, 6
IC = ICHAR( SUBNAM( I: I ) )
IF( IC.GE.225 .AND. IC.LE.250 )
$ SUBNAM( I: I ) = CHAR( IC-32 )
40 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 ( 50, 60, 70 )ISPEC
*
50 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 = 32
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 = 32
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
*
60 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 = 8
ELSE
NBMIN = 8
END IF
ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
NBMIN = 2
END IF
ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
IF( C3.EQ.'TRD' ) THEN
NBMIN = 2
END IF
ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
IF( C3( 1: 1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NBMIN = 2
END IF
ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NBMIN = 2
END IF
END IF
ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
IF( C3( 1: 1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NBMIN = 2
END IF
ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NBMIN = 2
END IF
END IF
END IF
ILAENV = NBMIN
RETURN
*
70 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 = 32
END IF
ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
IF( C3.EQ.'TRD' ) THEN
NX = 32
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
*
80 CONTINUE
*
* ISPEC = 4: number of shifts (used by xHSEQR)
*
ILAENV = 6
RETURN
*
90 CONTINUE
*
* ISPEC = 5: minimum column dimension (not used)
*
ILAENV = 2
RETURN
*
100 CONTINUE
*
* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD)
*
ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
RETURN
*
110 CONTINUE
*
* ISPEC = 7: number of processors (not used)
*
ILAENV = 1
RETURN
*
120 CONTINUE
*
* ISPEC = 8: crossover point for multishift (used by xHSEQR)
*
ILAENV = 50
RETURN
*
130 CONTINUE
*
* ISPEC = 9: maximum size of the subproblems at the bottom of the
* computation tree in the divide-and-conquer algorithm
* (used by xGELSD and xGESDD)
*
ILAENV = 25
RETURN
*
140 CONTINUE
*
* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap
*
* ILAENV = 0
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 1, 0.0, 1.0 )
END IF
RETURN
*
150 CONTINUE
*
* ISPEC = 11: infinity arithmetic can be trusted not to trap
*
* ILAENV = 0
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 0, 0.0, 1.0 )
END IF
RETURN
*
160 CONTINUE
*
* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines.
*
ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
RETURN
*
* End of ILAENV
*
END
DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 AP( * )
* ..
*
* Purpose
* =======
*
* ZLANHP returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* complex hermitian matrix A, supplied in packed form.
*
* Description
* ===========
*
* ZLANHP returns the value
*
* ZLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in ZLANHP as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* hermitian matrix A is supplied.
* = 'U': Upper triangular part of A is supplied
* = 'L': Lower triangular part of A is supplied
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, ZLANHP is
* set to zero.
*
* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
* The upper or lower triangle of the hermitian matrix A, packed
* columnwise in a linear array. The j-th column of A is stored
* in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
* Note that the imaginary parts of the diagonal elements need
* not be set and are assumed to be zero.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
K = 0
DO 20 J = 1, N
DO 10 I = K + 1, K + J - 1
VALUE = MAX( VALUE, ABS( AP( I ) ) )
10 CONTINUE
K = K + J
VALUE = MAX( VALUE, ABS( DBLE( AP( K ) ) ) )
20 CONTINUE
ELSE
K = 1
DO 40 J = 1, N
VALUE = MAX( VALUE, ABS( DBLE( AP( K ) ) ) )
DO 30 I = K + 1, K + N - J
VALUE = MAX( VALUE, ABS( AP( I ) ) )
30 CONTINUE
K = K + N - J + 1
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is hermitian).
*
VALUE = ZERO
K = 1
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
50 CONTINUE
WORK( J ) = SUM + ABS( DBLE( AP( K ) ) )
K = K + 1
60 CONTINUE
DO 70 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( DBLE( AP( K ) ) )
K = K + 1
DO 90 I = J + 1, N
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
90 CONTINUE
VALUE = MAX( VALUE, SUM )
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
K = 2
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM )
K = K + J
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
120 CONTINUE
END IF
SUM = 2*SUM
K = 1
DO 130 I = 1, N
IF( DBLE( AP( K ) ).NE.ZERO ) THEN
ABSA = ABS( DBLE( AP( K ) ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
IF( LSAME( UPLO, 'U' ) ) THEN
K = K + I + 1
ELSE
K = K + N - I + 1
END IF
130 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANHP = VALUE
RETURN
*
* End of ZLANHP
*
END
SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 AP( * ), TAU( * )
* ..
*
* Purpose
* =======
*
* ZHPTRD reduces a complex Hermitian matrix A stored in packed form to
* real symmetric tridiagonal form T by a unitary similarity
* transformation: Q**H * A * Q = T.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the Hermitian matrix
* A, packed columnwise in a linear array. The j-th column of A
* is stored in the array AP as follows:
* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
* On exit, if UPLO = 'U', the diagonal and first superdiagonal
* of A are overwritten by the corresponding elements of the
* tridiagonal matrix T, and the elements above the first
* superdiagonal, with the array TAU, represent the unitary
* matrix Q as a product of elementary reflectors; if UPLO
* = 'L', the diagonal and first subdiagonal of A are over-
* written by the corresponding elements of the tridiagonal
* matrix T, and the elements below the first subdiagonal, with
* the array TAU, represent the unitary matrix Q as a product
* of elementary reflectors. See Further Details.
*
* D (output) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of the tridiagonal matrix T:
* D(i) = A(i,i).
*
* E (output) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix T:
* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*
* TAU (output) COMPLEX*16 array, dimension (N-1)
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n-1) . . . H(2) H(1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a complex scalar, and v is a complex vector with
* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(n-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a complex scalar, and v is a complex vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
* overwriting A(i+2:n,i), and tau is stored in TAU(i).
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO, HALF
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ),
$ HALF = ( 0.5D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, I1, I1I1, II
COMPLEX*16 ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZHPMV, ZHPR2, ZLARFG
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. 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
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPTRD', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A.
* I1 is the index in AP of A(1,I+1).
*
I1 = N*( N-1 ) / 2 + 1
AP( I1+N-1 ) = DBLE( AP( I1+N-1 ) )
DO 10 I = N - 1, 1, -1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(1:i-1,i+1)
*
ALPHA = AP( I1+I-1 )
CALL ZLARFG( I, ALPHA, AP( I1 ), 1, TAUI )
E( I ) = ALPHA
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(1:i,1:i)
*
AP( I1+I-1 ) = ONE
*
* Compute y := tau * A * v storing y in TAU(1:i)
*
CALL ZHPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
$ 1 )
*
* Compute w := y - 1/2 * tau * (y'*v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, AP( I1 ), 1 )
CALL ZAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL ZHPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
*
END IF
AP( I1+I-1 ) = E( I )
D( I+1 ) = AP( I1+I )
TAU( I ) = TAUI
I1 = I1 - I
10 CONTINUE
D( 1 ) = AP( 1 )
ELSE
*
* Reduce the lower triangle of A. II is the index in AP of
* A(i,i) and I1I1 is the index of A(i+1,i+1).
*
II = 1
AP( 1 ) = DBLE( AP( 1 ) )
DO 20 I = 1, N - 1
I1I1 = II + N - I + 1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(i+2:n,i)
*
ALPHA = AP( II+1 )
CALL ZLARFG( N-I, ALPHA, AP( II+2 ), 1, TAUI )
E( I ) = ALPHA
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(i+1:n,i+1:n)
*
AP( II+1 ) = ONE
*
* Compute y := tau * A * v storing y in TAU(i:n-1)
*
CALL ZHPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
$ ZERO, TAU( I ), 1 )
*
* Compute w := y - 1/2 * tau * (y'*v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, AP( II+1 ),
$ 1 )
CALL ZAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL ZHPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
$ AP( I1I1 ) )
*
END IF
AP( II+1 ) = E( I )
D( I ) = AP( II )
TAU( I ) = TAUI
II = I1I1
20 CONTINUE
D( N ) = AP( II )
END IF
*
RETURN
*
* End of ZHPTRD
*
END
SUBROUTINE DSTERF( N, D, E, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
$ NMAXIT
DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
$ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
$ SIGMA, SSFMAX, SSFMIN
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLASCL, DLASRT, 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' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues of the tridiagonal matrix.
*
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
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 170
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
DO 20 M = L1, N - 1
IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
DO 40 I = L, LEND - 1
E( I ) = E( I )**2
40 CONTINUE
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GE.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
50 CONTINUE
IF( L.NE.LEND ) THEN
DO 60 M = L, LEND - 1
IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*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 150
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
*
DO 80 I = M - 1, 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 150
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
100 CONTINUE
DO 110 M = L, LEND + 1, -1
IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) )
$ GO TO 120
110 CONTINUE
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 150
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
*
DO 130 I = M, L - 1
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( L-1 ) = 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 150
*
END IF
*
* Undo scaling if necessary
*
150 CONTINUE
IF( ISCALE.EQ.1 )
$ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
IF( ISCALE.EQ.2 )
$ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.LT.NMAXIT )
$ GO TO 10
DO 160 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
160 CONTINUE
GO TO 180
*
* Sort eigenvalues in increasing order.
*
170 CONTINUE
CALL DLASRT( 'I', N, D, INFO )
*
180 CONTINUE
RETURN
*
* End of DSTERF
*
END
SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDQ, N
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZUPGTR generates a complex unitary matrix Q which is defined as the
* product of n-1 elementary reflectors H(i) of order n, as returned by
* ZHPTRD using packed storage:
*
* 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 triangular packed storage used in previous
* call to ZHPTRD;
* = 'L': Lower triangular packed storage used in previous
* call to ZHPTRD.
*
* N (input) INTEGER
* The order of the matrix Q. N >= 0.
*
* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
* The vectors which define the elementary reflectors, as
* returned by ZHPTRD.
*
* TAU (input) COMPLEX*16 array, dimension (N-1)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by ZHPTRD.
*
* Q (output) COMPLEX*16 array, dimension (LDQ,N)
* The N-by-N unitary matrix Q.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* WORK (workspace) COMPLEX*16 array, dimension (N-1)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IINFO, IJ, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNG2L, ZUNG2R
* ..
* .. 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( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUPGTR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Q was determined by a call to ZHPTRD with UPLO = 'U'
*
* Unpack the vectors which define the elementary reflectors and
* set the last row and column of Q equal to those of the unit
* matrix
*
IJ = 2
DO 20 J = 1, N - 1
DO 10 I = 1, J - 1
Q( I, J ) = AP( IJ )
IJ = IJ + 1
10 CONTINUE
IJ = IJ + 2
Q( N, J ) = CZERO
20 CONTINUE
DO 30 I = 1, N - 1
Q( I, N ) = CZERO
30 CONTINUE
Q( N, N ) = CONE
*
* Generate Q(1:n-1,1:n-1)
*
CALL ZUNG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
*
ELSE
*
* Q was determined by a call to ZHPTRD with UPLO = 'L'.
*
* Unpack the vectors which define the elementary reflectors and
* set the first row and column of Q equal to those of the unit
* matrix
*
Q( 1, 1 ) = CONE
DO 40 I = 2, N
Q( I, 1 ) = CZERO
40 CONTINUE
IJ = 3
DO 60 J = 2, N
Q( 1, J ) = CZERO
DO 50 I = J + 1, N
Q( I, J ) = AP( IJ )
IJ = IJ + 1
50 CONTINUE
IJ = IJ + 2
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Generate Q(2:n,2:n)
*
CALL ZUNG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
$ IINFO )
END IF
END IF
RETURN
*
* End of ZUPGTR
*
END
SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), WORK( * )
COMPLEX*16 Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
* symmetric tridiagonal matrix using the implicit QL or QR method.
* The eigenvectors of a full or band complex Hermitian matrix can also
* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
* matrix to tridiagonal form.
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'V': Compute eigenvalues and eigenvectors of the original
* Hermitian matrix. On entry, Z must contain the
* unitary matrix used to reduce the original matrix
* to tridiagonal form.
* = 'I': Compute eigenvalues and eigenvectors of the
* tridiagonal matrix. Z is initialized to the identity
* matrix.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', then Z contains the unitary
* matrix used in the reduction to tridiagonal form.
* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
* orthonormal eigenvectors of the original Hermitian matrix,
* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
* of the symmetric tridiagonal matrix.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* eigenvectors are desired, then LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
* If COMPZ = 'N', then WORK is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm has failed to find all the eigenvalues in
* a total of 30*N iterations; if INFO = i, then i
* elements of E have not converged to zero; on exit, D
* and E contain the elements of a symmetric tridiagonal
* matrix which is unitarily similar to the original
* matrix.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ),
$ CONE = ( 1.0D0, 0.0D0 ) )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
$ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
$ NM1, NMAXIT
DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA,
$ ZLASET, ZLASR, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.EQ.2 )
$ Z( 1, 1 ) = CONE
RETURN
END IF
*
* Determine the unit roundoff and over/underflow thresholds.
*
EPS = DLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues and eigenvectors of the tridiagonal
* matrix.
*
IF( ICOMPZ.EQ.2 )
$ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
*
NMAXIT = N*MAXIT
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
NM1 = N - 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 160
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
IF( L1.LE.NM1 ) THEN
DO 20 M = L1, NM1
TST = ABS( E( M ) )
IF( TST.EQ.ZERO )
$ GO TO 30
IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
END IF
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.EQ.ZERO )
$ GO TO 10
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GT.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
40 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 50 M = L, LENDM1
TST = ABS( E( M ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
$ SAFMIN )GO TO 60
50 CONTINUE
END IF
*
M = LEND
*
60 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 80
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
WORK( L ) = C
WORK( N-1+L ) = S
CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
END IF
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L+1 )-P ) / ( TWO*E( L ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
MM1 = M - 1
DO 70 I = MM1, L, -1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M-1 )
$ E( I+1 ) = R
G = D( I+1 ) - P
R = ( D( I )-G )*S + TWO*C*B
P = S*R
D( I+1 ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = -S
END IF
*
70 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = M - L + 1
CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
$ Z( 1, L ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( L ) = G
GO TO 40
*
* Eigenvalue found.
*
80 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
90 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 100 M = L, LENDP1, -1
TST = ABS( E( M-1 ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
$ SAFMIN )GO TO 110
100 CONTINUE
END IF
*
M = LEND
*
110 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 130
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
WORK( M ) = C
WORK( N-1+M ) = S
CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
END IF
D( L-1 ) = RT1
D( L ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
LM1 = L - 1
DO 120 I = M, LM1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M )
$ E( I-1 ) = R
G = D( I ) - P
R = ( D( I+1 )-G )*S + TWO*C*B
P = S*R
D( I ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = S
END IF
*
120 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = L - M + 1
CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
$ Z( 1, M ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( LM1 ) = G
GO TO 90
*
* Eigenvalue found.
*
130 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
*
END IF
*
* Undo scaling if necessary
*
140 CONTINUE
IF( ISCALE.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
ELSE IF( ISCALE.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
END IF
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.EQ.NMAXIT ) THEN
DO 150 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
150 CONTINUE
RETURN
END IF
GO TO 10
*
* Order eigenvalues and eigenvectors.
*
160 CONTINUE
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL DLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 180 II = 2, N
I = II - 1
K = I
P = D( I )
DO 170 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
170 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
END IF
RETURN
*
* End of ZSTEQR
*
END
DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 A( LDA, * )
* ..
*
* Purpose
* =======
*
* ZLANSY returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* complex symmetric matrix A.
*
* Description
* ===========
*
* ZLANSY returns the value
*
* ZLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in ZLANSY 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, ZLANSY is
* set to zero.
*
* A (input) COMPLEX*16 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 (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, 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 ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
120 CONTINUE
END IF
SUM = 2*SUM
CALL ZLASSQ( N, A, LDA+1, SCALE, SUM )
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANSY = VALUE
RETURN
*
* End of ZLANSY
*
END
SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZHETRD reduces a complex Hermitian matrix A to real symmetric
* tridiagonal form T by a unitary similarity transformation:
* Q**H * A * Q = T.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A is stored;
* = 'L': Lower triangle of A is stored.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
* N-by-N upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
* On exit, if UPLO = 'U', the diagonal and first superdiagonal
* of A are overwritten by the corresponding elements of the
* tridiagonal matrix T, and the elements above the first
* superdiagonal, with the array TAU, represent the unitary
* matrix Q as a product of elementary reflectors; if UPLO
* = 'L', the diagonal and first subdiagonal of A are over-
* written by the corresponding elements of the tridiagonal
* matrix T, and the elements below the first subdiagonal, with
* the array TAU, represent the unitary matrix Q as a product
* of elementary reflectors. See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* D (output) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of the tridiagonal matrix T:
* D(i) = A(i,i).
*
* E (output) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix T:
* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*
* TAU (output) COMPLEX*16 array, dimension (N-1)
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= 1.
* For optimum performance LWORK >= N*NB, where NB is the
* optimal blocksize.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n-1) . . . H(2) H(1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a complex scalar, and v is a complex vector with
* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
* A(1:i-1,i+1), and tau in TAU(i).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(n-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a complex scalar, and v is a complex vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
* and tau in TAU(i).
*
* The contents of A on exit are illustrated by the following examples
* with n = 5:
*
* if UPLO = 'U': if UPLO = 'L':
*
* ( d e v2 v3 v4 ) ( d )
* ( d e v3 v4 ) ( e d )
* ( d e v4 ) ( v1 e d )
* ( d e ) ( v1 v2 e d )
* ( d ) ( v1 v2 v3 e d )
*
* where d and e denote diagonal and off-diagonal elements of T, and vi
* denotes an element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZHER2K, ZHETD2, ZLATRD
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size.
*
NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHETRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NX = N
IWS = 1
IF( NB.GT.1 .AND. NB.LT.N ) THEN
*
* Determine when to cross over from blocked to unblocked code
* (last block is always handled by unblocked code).
*
NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) )
IF( NX.LT.N ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: determine the
* minimum value of NB, and reduce NB or force use of
* unblocked code by setting NX = N.
*
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 )
IF( NB.LT.NBMIN )
$ NX = N
END IF
ELSE
NX = N
END IF
ELSE
NB = 1
END IF
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A.
* Columns 1:kk are handled by the unblocked method.
*
KK = N - ( ( N-NX+NB-1 ) / NB )*NB
DO 20 I = N - NB + 1, KK + 1, -NB
*
* Reduce columns i:i+nb-1 to tridiagonal form and form the
* matrix W which is needed to update the unreduced part of
* the matrix
*
CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
$ LDWORK )
*
* Update the unreduced submatrix A(1:i-1,1:i-1), using an
* update of the form: A := A - V*W' - W*V'
*
CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE,
$ A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA )
*
* Copy superdiagonal elements back into A, and diagonal
* elements into D
*
DO 10 J = I, I + NB - 1
A( J-1, J ) = E( J-1 )
D( J ) = A( J, J )
10 CONTINUE
20 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
ELSE
*
* Reduce the lower triangle of A
*
DO 40 I = 1, N - NX, NB
*
* Reduce columns i:i+nb-1 to tridiagonal form and form the
* matrix W which is needed to update the unreduced part of
* the matrix
*
CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
$ TAU( I ), WORK, LDWORK )
*
* Update the unreduced submatrix A(i+nb:n,i+nb:n), using
* an update of the form: A := A - V*W' - W*V'
*
CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE,
$ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
$ A( I+NB, I+NB ), LDA )
*
* Copy subdiagonal elements back into A, and diagonal
* elements into D
*
DO 30 J = I, I + NB - 1
A( J+1, J ) = E( J )
D( J ) = A( J, J )
30 CONTINUE
40 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
$ TAU( I ), IINFO )
END IF
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZHETRD
*
END
INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )
*
* -- LAPACK auxiliary routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
*
* .. Scalar Arguments ..
INTEGER ISPEC
REAL ONE, ZERO
* ..
*
* Purpose
* =======
*
* IEEECK is called from the ILAENV to verify that Infinity and
* possibly NaN arithmetic is safe (i.e. will not trap).
*
* Arguments
* =========
*
* ISPEC (input) INTEGER
* Specifies whether to test just for inifinity arithmetic
* or whether to test for infinity and NaN arithmetic.
* = 0: Verify infinity arithmetic only.
* = 1: Verify infinity and NaN arithmetic.
*
* ZERO (input) REAL
* Must contain the value 0.0
* This is passed to prevent the compiler from optimizing
* away this code.
*
* ONE (input) REAL
* Must contain the value 1.0
* This is passed to prevent the compiler from optimizing
* away this code.
*
* RETURN VALUE: INTEGER
* = 0: Arithmetic failed to produce the correct answers
* = 1: Arithmetic produced the correct answers
*
* .. Local Scalars ..
REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
$ NEGZRO, NEWZRO, POSINF
* ..
* .. Executable Statements ..
IEEECK = 1
*
POSINF = ONE / ZERO
IF( POSINF.LE.ONE ) THEN
IEEECK = 0
RETURN
END IF
*
NEGINF = -ONE / ZERO
IF( NEGINF.GE.ZERO ) THEN
IEEECK = 0
RETURN
END IF
*
NEGZRO = ONE / ( NEGINF+ONE )
IF( NEGZRO.NE.ZERO ) THEN
IEEECK = 0
RETURN
END IF
*
NEGINF = ONE / NEGZRO
IF( NEGINF.GE.ZERO ) THEN
IEEECK = 0
RETURN
END IF
*
NEWZRO = NEGZRO + ZERO
IF( NEWZRO.NE.ZERO ) THEN
IEEECK = 0
RETURN
END IF
*
POSINF = ONE / NEWZRO
IF( POSINF.LE.ONE ) THEN
IEEECK = 0
RETURN
END IF
*
NEGINF = NEGINF*POSINF
IF( NEGINF.GE.ZERO ) THEN
IEEECK = 0
RETURN
END IF
*
POSINF = POSINF*POSINF
IF( POSINF.LE.ONE ) THEN
IEEECK = 0
RETURN
END IF
*
*
*
*
* Return if we were only asked to check infinity arithmetic
*
IF( ISPEC.EQ.0 )
$ RETURN
*
NAN1 = POSINF + NEGINF
*
NAN2 = POSINF / NEGINF
*
NAN3 = POSINF / POSINF
*
NAN4 = POSINF*ZERO
*
NAN5 = NEGINF*NEGZRO
*
NAN6 = NAN5*ZERO
*
IF( NAN1.EQ.NAN1 ) THEN
IEEECK = 0
RETURN
END IF
*
IF( NAN2.EQ.NAN2 ) THEN
IEEECK = 0
RETURN
END IF
*
IF( NAN3.EQ.NAN3 ) THEN
IEEECK = 0
RETURN
END IF
*
IF( NAN4.EQ.NAN4 ) THEN
IEEECK = 0
RETURN
END IF
*
IF( NAN5.EQ.NAN5 ) THEN
IEEECK = 0
RETURN
END IF
*
IF( NAN6.EQ.NAN6 ) THEN
IEEECK = 0
RETURN
END IF
*
RETURN
END
SUBROUTINE ZSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
$ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
$ IWORK, LIWORK, INFO )
IMPLICIT NONE
*
* -- LAPACK computational routine (version 3.2.1) --
*
* -- April 2009 --
*
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
LOGICAL TRYRAC
INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
DOUBLE PRECISION VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
COMPLEX*16 Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* ZSTEMR computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
* a well defined set of pairwise different real eigenvalues, the corresponding
* real eigenvectors are pairwise orthogonal.
*
* The spectrum may be computed either completely or partially by specifying
* either an interval (VL,VU] or a range of indices IL:IU for the desired
* eigenvalues.
*
* Depending on the number of desired eigenvalues, these are computed either
* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
* computed by the use of various suitable L D L^T factorizations near clusters
* of close eigenvalues (referred to as RRRs, Relatively Robust
* Representations). An informal sketch of the algorithm follows.
*
* For each unreduced block (submatrix) of T,
* (a) Compute T - sigma I = L D L^T, so that L and D
* define all the wanted eigenvalues to high relative accuracy.
* This means that small relative changes in the entries of D and L
* cause only small relative changes in the eigenvalues and
* eigenvectors. The standard (unfactored) representation of the
* tridiagonal matrix T does not have this property in general.
* (b) Compute the eigenvalues to suitable accuracy.
* If the eigenvectors are desired, the algorithm attains full
* accuracy of the computed eigenvalues only right before
* the corresponding vectors have to be computed, see steps c) and d).
* (c) For each cluster of close eigenvalues, select a new
* shift close to the cluster, find a new factorization, and refine
* the shifted eigenvalues to suitable accuracy.
* (d) For each eigenvalue with a large enough relative separation compute
* the corresponding eigenvector by forming a rank revealing twisted
* factorization. Go back to (c) for any clusters that remain.
*
* For more details, see:
* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
* 2004. Also LAPACK Working Note 154.
* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
* tridiagonal eigenvalue/eigenvector problem",
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
* Further Details
* 1.ZSTEMR works only on machines which follow IEEE-754
* floating-point standard in their handling of infinities and NaNs.
* This permits the use of efficient inner loops avoiding a check for
* zero divisors.
*
* 2. LAPACK routines can be used to reduce a complex Hermitean matrix to
* real symmetric tridiagonal form.
*
* (Any complex Hermitean tridiagonal matrix has real values on its diagonal
* and potentially complex numbers on its off-diagonals. By applying a
* similarity transform with an appropriate diagonal matrix
* diag(1,e^{i \phy_1}, ... , e^{i \phy_{n-1}}), the complex Hermitean
* matrix can be transformed into a real symmetric matrix and complex
* arithmetic can be entirely avoided.)
*
* While the eigenvectors of the real symmetric tridiagonal matrix are real,
* the eigenvectors of original complex Hermitean matrix have complex entries
* in general.
* Since LAPACK drivers overwrite the matrix data with the eigenvectors,
* ZSTEMR accepts complex workspace to facilitate interoperability
* with ZUNMTR or ZUPMTR.
*
* 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.
*
* 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
* T. On exit, D is overwritten.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the (N-1) subdiagonal elements of the tridiagonal
* matrix T in elements 1 to N-1 of E. E(N) need not be set on
* input, but is used internally as workspace.
* On exit, E is overwritten.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* 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)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
* contain the orthonormal eigenvectors of the matrix T
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* 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 can be computed with a workspace
* query by setting NZC = -1, see below.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', then LDZ >= max(1,N).
*
* NZC (input) INTEGER
* The number of eigenvectors to be held in the array Z.
* If RANGE = 'A', then NZC >= max(1,N).
* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
* If RANGE = 'I', then NZC >= IU-IL+1.
* If NZC = -1, then a workspace query is assumed; the
* routine calculates the number of columns of the array Z that
* are needed to hold the eigenvectors.
* This value is returned as the first entry of the Z array, and
* no error message related to NZC is issued by XERBLA.
*
* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th computed eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ). This is relevant in the case when the matrix
* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
*
* TRYRAC (input/output) LOGICAL
* If TRYRAC.EQ..TRUE., indicates that the code should check whether
* the tridiagonal matrix defines its eigenvalues to high relative
* accuracy. If so, the code uses relative-accuracy preserving
* algorithms that might be (a bit) slower depending on the matrix.
* If the matrix does not define its eigenvalues to high relative
* accuracy, the code can uses possibly faster algorithms.
* If TRYRAC.EQ..FALSE., the code is not required to guarantee
* relatively accurate eigenvalues and can use the fastest possible
* techniques.
* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
* does not define its eigenvalues to high relative accuracy.
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal
* (and minimal) LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,18*N)
* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= max(1,10*N)
* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
* if only the eigenvalues are to be computed.
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* On exit, INFO
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = 1X, internal error in DLARRE,
* if INFO = 2X, internal error in ZLARRV.
* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
* the nonzero error code returned by DLARRE or
* ZLARRV, respectively.
*
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, FOUR, MINRGP
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
$ FOUR = 4.0D0,
$ MINRGP = 1.0D-3 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
INTEGER I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW,
$ IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD,
$ INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP,
$ ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT,
$ NZCMIN, OFFSET, WBEGIN, WEND
DOUBLE PRECISION BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN,
$ RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN,
$ THRESH, TMP, TNRM, WL, WU
* ..
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAE2, DLAEV2, DLARRC, DLARRE, DLARRJ,
$ DLARRR, DLASRT, DSCAL, XERBLA, ZLARRV, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
ZQUERY = ( NZC.EQ.-1 )
* DSTEMR needs WORK of size 6*N, IWORK of size 3*N.
* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N.
* Furthermore, ZLARRV needs WORK of size 12*N, IWORK of size 7*N.
IF( WANTZ ) THEN
LWMIN = 18*N
LIWMIN = 10*N
ELSE
* need less workspace if only the eigenvalues are wanted
LWMIN = 12*N
LIWMIN = 8*N
ENDIF
WL = ZERO
WU = ZERO
IIL = 0
IIU = 0
IF( VALEIG ) THEN
* We do not reference VL, VU in the cases RANGE = 'I','A'
* The interval (WL, WU] contains all the wanted eigenvalues.
* It is either given by the user or computed in DLARRE.
WL = VL
WU = VU
ELSEIF( INDEIG ) THEN
* We do not reference IL, IU in the cases RANGE = 'V','A'
IIL = IL
IIU = IU
ENDIF
*
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( N.LT.0 ) THEN
INFO = -3
ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN
INFO = -7
ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN
INFO = -8
ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -13
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -17
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -19
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 ) ) )
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( WANTZ .AND. ALLEIG ) THEN
NZCMIN = N
ELSE IF( WANTZ .AND. VALEIG ) THEN
CALL DLARRC( 'T', N, VL, VU, D, E, SAFMIN,
$ NZCMIN, ITMP, ITMP2, INFO )
ELSE IF( WANTZ .AND. INDEIG ) THEN
NZCMIN = IIU-IIL+1
ELSE
* WANTZ .EQ. FALSE.
NZCMIN = 0
ENDIF
IF( ZQUERY .AND. INFO.EQ.0 ) THEN
Z( 1,1 ) = NZCMIN
ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN
INFO = -14
END IF
END IF
IF( INFO.NE.0 ) THEN
*
CALL XERBLA( 'ZSTEMR', -INFO )
*
RETURN
ELSE IF( LQUERY .OR. ZQUERY ) THEN
RETURN
END IF
*
* Handle N = 0, 1, and 2 cases immediately
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = D( 1 )
ELSE
IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
M = 1
W( 1 ) = D( 1 )
END IF
END IF
IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
Z( 1, 1 ) = ONE
ISUPPZ(1) = 1
ISUPPZ(2) = 1
END IF
RETURN
END IF
*
IF( N.EQ.2 ) THEN
IF( .NOT.WANTZ ) THEN
CALL DLAE2( D(1), E(1), D(2), R1, R2 )
ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
CALL DLAEV2( D(1), E(1), D(2), R1, R2, CS, SN )
END IF
IF( ALLEIG.OR.
$ (VALEIG.AND.(R2.GT.WL).AND.
$ (R2.LE.WU)).OR.
$ (INDEIG.AND.(IIL.EQ.1)) ) THEN
M = M+1
W( M ) = R2
IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
Z( 1, M ) = -SN
Z( 2, M ) = CS
* Note: At most one of SN and CS can be zero.
IF (SN.NE.ZERO) THEN
IF (CS.NE.ZERO) THEN
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M-1) = 2
ELSE
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M-1) = 1
END IF
ELSE
ISUPPZ(2*M-1) = 2
ISUPPZ(2*M) = 2
END IF
ENDIF
ENDIF
IF( ALLEIG.OR.
$ (VALEIG.AND.(R1.GT.WL).AND.
$ (R1.LE.WU)).OR.
$ (INDEIG.AND.(IIU.EQ.2)) ) THEN
M = M+1
W( M ) = R1
IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
Z( 1, M ) = CS
Z( 2, M ) = SN
* Note: At most one of SN and CS can be zero.
IF (SN.NE.ZERO) THEN
IF (CS.NE.ZERO) THEN
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M-1) = 2
ELSE
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M-1) = 1
END IF
ELSE
ISUPPZ(2*M-1) = 2
ISUPPZ(2*M) = 2
END IF
ENDIF
ENDIF
RETURN
END IF
* Continue with general N
INDGRS = 1
INDERR = 2*N + 1
INDGP = 3*N + 1
INDD = 4*N + 1
INDE2 = 5*N + 1
INDWRK = 6*N + 1
*
IINSPL = 1
IINDBL = N + 1
IINDW = 2*N + 1
IINDWK = 3*N + 1
*
* Scale matrix to allowable range, if necessary.
* The allowable range is related to the PIVMIN parameter; see the
* comments in DLARRD. The preference for scaling small values
* up is heuristic; we expect users' matrices not to be close to the
* RMAX threshold.
*
SCALE = ONE
TNRM = DLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
SCALE = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
SCALE = RMAX / TNRM
END IF
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( N, SCALE, D, 1 )
CALL DSCAL( N-1, SCALE, E, 1 )
TNRM = TNRM*SCALE
IF( VALEIG ) THEN
* If eigenvalues in interval have to be found,
* scale (WL, WU] accordingly
WL = WL*SCALE
WU = WU*SCALE
ENDIF
END IF
*
* Compute the desired eigenvalues of the tridiagonal after splitting
* into smaller subblocks if the corresponding off-diagonal elements
* are small
* THRESH is the splitting parameter for DLARRE
* A negative THRESH forces the old splitting criterion based on the
* size of the off-diagonal. A positive THRESH switches to splitting
* which preserves relative accuracy.
*
IF( TRYRAC ) THEN
* Test whether the matrix warrants the more expensive relative approach.
CALL DLARRR( N, D, E, IINFO )
ELSE
* The user does not care about relative accurately eigenvalues
IINFO = -1
ENDIF
* Set the splitting criterion
IF (IINFO.EQ.0) THEN
THRESH = EPS
ELSE
THRESH = -EPS
* relative accuracy is desired but T does not guarantee it
TRYRAC = .FALSE.
ENDIF
*
IF( TRYRAC ) THEN
* Copy original diagonal, needed to guarantee relative accuracy
CALL DCOPY(N,D,1,WORK(INDD),1)
ENDIF
* Store the squares of the offdiagonal values of T
DO 5 J = 1, N-1
WORK( INDE2+J-1 ) = E(J)**2
5 CONTINUE
* Set the tolerance parameters for bisection
IF( .NOT.WANTZ ) THEN
* DLARRE computes the eigenvalues to full precision.
RTOL1 = FOUR * EPS
RTOL2 = FOUR * EPS
ELSE
* DLARRE computes the eigenvalues to less than full precision.
* ZLARRV will refine the eigenvalue approximations, and we only
* need less accurate initial bisection in DLARRE.
* Note: these settings do only affect the subset case and DLARRE
RTOL1 = SQRT(EPS)
RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS )
ENDIF
CALL DLARRE( RANGE, N, WL, WU, IIL, IIU, D, E,
$ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
$ IWORK( IINSPL ), M, W, WORK( INDERR ),
$ WORK( INDGP ), IWORK( IINDBL ),
$ IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
$ WORK( INDWRK ), IWORK( IINDWK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 10 + ABS( IINFO )
RETURN
END IF
* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired
* part of the spectrum. All desired eigenvalues are contained in
* (WL,WU]
IF( WANTZ ) THEN
*
* Compute the desired eigenvectors corresponding to the computed
* eigenvalues
*
CALL ZLARRV( N, WL, WU, D, E,
$ PIVMIN, IWORK( IINSPL ), M,
$ 1, M, MINRGP, RTOL1, RTOL2,
$ W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
$ IWORK( IINDW ), WORK( INDGRS ), Z, LDZ,
$ ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 20 + ABS( IINFO )
RETURN
END IF
ELSE
* DLARRE computes eigenvalues of the (shifted) root representation
* ZLARRV returns the eigenvalues of the unshifted matrix.
* However, if the eigenvectors are not desired by the user, we need
* to apply the corresponding shifts from DLARRE to obtain the
* eigenvalues of the original matrix.
DO 20 J = 1, M
ITMP = IWORK( IINDBL+J-1 )
W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
20 CONTINUE
END IF
*
IF ( TRYRAC ) THEN
* Refine computed eigenvalues so that they are relatively accurate
* with respect to the original matrix T.
IBEGIN = 1
WBEGIN = 1
DO 39 JBLK = 1, IWORK( IINDBL+M-1 )
IEND = IWORK( IINSPL+JBLK-1 )
IN = IEND - IBEGIN + 1
WEND = WBEGIN - 1
* check if any eigenvalues have to be refined in this block
36 CONTINUE
IF( WEND.LT.M ) THEN
IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN
WEND = WEND + 1
GO TO 36
END IF
END IF
IF( WEND.LT.WBEGIN ) THEN
IBEGIN = IEND + 1
GO TO 39
END IF
OFFSET = IWORK(IINDW+WBEGIN-1)-1
IFIRST = IWORK(IINDW+WBEGIN-1)
ILAST = IWORK(IINDW+WEND-1)
RTOL2 = FOUR * EPS
CALL DLARRJ( IN,
$ WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1),
$ IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN),
$ WORK( INDERR+WBEGIN-1 ),
$ WORK( INDWRK ), IWORK( IINDWK ), PIVMIN,
$ TNRM, IINFO )
IBEGIN = IEND + 1
WBEGIN = WEND + 1
39 CONTINUE
ENDIF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( M, ONE / SCALE, W, 1 )
END IF
*
* If eigenvalues are not in increasing order, then sort them,
* possibly along with eigenvectors.
*
IF( NSPLIT.GT.1 ) THEN
IF( .NOT. WANTZ ) THEN
CALL DLASRT( 'I', M, W, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 3
RETURN
END IF
ELSE
DO 60 J = 1, M - 1
I = 0
TMP = W( J )
DO 50 JJ = J + 1, M
IF( W( JJ ).LT.TMP ) THEN
I = JJ
TMP = W( JJ )
END IF
50 CONTINUE
IF( I.NE.0 ) THEN
W( I ) = W( J )
W( J ) = TMP
IF( WANTZ ) THEN
CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
ITMP = ISUPPZ( 2*I-1 )
ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
ISUPPZ( 2*J-1 ) = ITMP
ITMP = ISUPPZ( 2*I )
ISUPPZ( 2*I ) = ISUPPZ( 2*J )
ISUPPZ( 2*J ) = ITMP
END IF
END IF
60 CONTINUE
END IF
ENDIF
*
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
RETURN
*
* End of ZSTEMR
*
END
SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, UPLO
INTEGER INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZUNMTR overwrites the general complex M-by-N matrix C with
*
* SIDE = 'L' SIDE = 'R'
* TRANS = 'N': Q * C C * Q
* TRANS = 'C': Q**H * C C * Q**H
*
* where Q is a complex unitary matrix 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 ZHETRD:
*
* 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**H from the Left;
* = 'R': apply Q or Q**H from the Right.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangle of A contains elementary reflectors
* from ZHETRD;
* = 'L': Lower triangle of A contains elementary reflectors
* from ZHETRD.
*
* TRANS (input) CHARACTER*1
* = 'N': No transpose, apply Q;
* = 'C': Conjugate transpose, apply Q**H.
*
* M (input) INTEGER
* The number of rows of the matrix C. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix C. N >= 0.
*
* A (input) COMPLEX*16 array, dimension
* (LDA,M) if SIDE = 'L'
* (LDA,N) if SIDE = 'R'
* The vectors which define the elementary reflectors, as
* returned by ZHETRD.
*
* 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) COMPLEX*16 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 ZHETRD.
*
* C (input/output) COMPLEX*16 array, dimension (LDC,N)
* On entry, the M-by-N matrix C.
* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If SIDE = 'L', LWORK >= max(1,N);
* if SIDE = 'R', LWORK >= max(1,M).
* For optimum performance LWORK >= N*NB if SIDE = 'L', and
* LWORK >=M*NB if SIDE = 'R', where NB is the optimal
* blocksize.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, UPPER
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNMQL, ZUNMQR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) )
$ THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
IF( UPPER ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
ELSE
IF( LEFT ) THEN
NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
END IF
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMTR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
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 ZHETRD with UPLO = 'U'
*
CALL ZUNMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
$ LDC, WORK, LWORK, IINFO )
ELSE
*
* Q was determined by a call to ZHETRD with UPLO = 'L'
*
IF( LEFT ) THEN
I1 = 2
I2 = 1
ELSE
I1 = 1
I2 = 2
END IF
CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
$ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMTR
*
END
SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
$ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
* 8-18-00: Increase FUDGE factor for T3E (eca)
*
* .. 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.
*
* To avoid overflow, the matrix must be scaled so that its
* largest element 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.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966.
*
* Arguments
* =========
*
* RANGE (input) CHARACTER*1
* = '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*1
* = '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 order of the tridiagonal matrix T. N >= 0.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. Eigenvalues less than or equal
* to VL, or greater than VU, will not be returned. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* 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.
*
* Eigenvalues will be computed most accurately when ABSTOL is
* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) off-diagonal elements of the tridiagonal matrix T.
*
* 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, if INFO = 0, IBLOCK(i) specifies to which
* block (from 1 to the number of blocks) the eigenvalue W(i)
* belongs. (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.1D0, 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' ) ) 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 ) THEN
IF( VL.GE.VU )
$ 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
*
ccccc DIR NOVECTOR
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
ELSE
WL = ZERO
WU = ZERO
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
*
* Compute ATOLI for the current submatrix
*
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) )
ELSE
ATOLI = ABSTOL
END IF
*
IF( IRANGE.GT.1 ) THEN
IF( GU.LT.WL ) THEN
NWL = NWL + IN
NWU = NWU + IN
GO TO 70
END IF
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', 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
SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
$ IWORK, IFAIL, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, LDZ, M, N
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
$ IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
COMPLEX*16 Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* ZSTEIN 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).
*
* Although the eigenvectors are real, they are stored in a complex
* array, which may be passed to ZUNMTR or ZUPMTR for back
* transformation to the eigenvectors of a complex Hermitian matrix
* which was reduced to tridiagonal form.
*
*
* 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-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix
* T, stored in elements 1 to N-1.
*
* 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) COMPLEX*16 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.
* The imaginary parts of the eigenvectors are set to zero.
*
* 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 ..
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
$ 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, JR, 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, DLAMCH, DNRM2
EXTERNAL IDAMAX, DASUM, DLAMCH, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, 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( 'ZSTEIN', -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 ) = CONE
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.
*
J1 = 1
DO 180 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
GPIND = B1
*
* 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 170 J = J1, M
IF( IBLOCK( J ).NE.NBLK ) THEN
J1 = J
GO TO 180
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 140
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( 2, 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 120
*
* 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 110
IF( ABS( XJ-XJM ).GT.ORTOL )
$ GPIND = J
IF( GPIND.NE.J ) THEN
DO 100 I = GPIND, J - 1
ZTR = ZERO
DO 80 JR = 1, BLKSIZ
ZTR = ZTR + WORK( INDRV1+JR )*
$ DBLE( Z( B1-1+JR, I ) )
80 CONTINUE
DO 90 JR = 1, BLKSIZ
WORK( INDRV1+JR ) = WORK( INDRV1+JR ) -
$ ZTR*DBLE( Z( B1-1+JR, I ) )
90 CONTINUE
100 CONTINUE
END IF
*
* Check the infinity norm of the iterate.
*
110 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 130
*
* If stopping criterion was not satisfied, update info and
* store eigenvector number in array ifail.
*
120 CONTINUE
INFO = INFO + 1
IFAIL( INFO ) = J
*
* Accept iterate as jth eigenvector.
*
130 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 )
140 CONTINUE
DO 150 I = 1, N
Z( I, J ) = CZERO
150 CONTINUE
DO 160 I = 1, BLKSIZ
Z( B1+I-1, J ) = DCMPLX( WORK( INDRV1+I ), ZERO )
160 CONTINUE
*
* Save the shift to check eigenvalue spacing at next
* iteration.
*
XJM = XJ
*
170 CONTINUE
180 CONTINUE
*
RETURN
*
* End of ZSTEIN
*
END
SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
$ INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, UPLO
INTEGER INFO, LDC, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZUPMTR overwrites the general complex M-by-N matrix C with
*
* SIDE = 'L' SIDE = 'R'
* TRANS = 'N': Q * C C * Q
* TRANS = 'C': Q**H * C C * Q**H
*
* where Q is a complex unitary matrix 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 ZHPTRD using packed
* storage:
*
* 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**H from the Left;
* = 'R': apply Q or Q**H from the Right.
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular packed storage used in previous
* call to ZHPTRD;
* = 'L': Lower triangular packed storage used in previous
* call to ZHPTRD.
*
* TRANS (input) CHARACTER*1
* = 'N': No transpose, apply Q;
* = 'C': Conjugate transpose, apply Q**H.
*
* M (input) INTEGER
* The number of rows of the matrix C. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix C. N >= 0.
*
* AP (input) COMPLEX*16 array, dimension
* (M*(M+1)/2) if SIDE = 'L'
* (N*(N+1)/2) if SIDE = 'R'
* The vectors which define the elementary reflectors, as
* returned by ZHPTRD. AP is modified by the routine but
* restored on exit.
*
* TAU (input) COMPLEX*16 array, dimension (M-1) if SIDE = 'L'
* or (N-1) if SIDE = 'R'
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by ZHPTRD.
*
* C (input/output) COMPLEX*16 array, dimension (LDC,N)
* On entry, the M-by-N matrix C.
* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace) COMPLEX*16 array, dimension
* (N) if SIDE = 'L'
* (M) if SIDE = 'R'
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL FORWRD, LEFT, NOTRAN, UPPER
INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ
COMPLEX*16 AII, TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
UPPER = LSAME( UPLO, 'U' )
*
* 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.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUPMTR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Q was determined by a call to ZHPTRD with UPLO = 'U'
*
FORWRD = ( LEFT .AND. NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. .NOT.NOTRAN )
*
IF( FORWRD ) THEN
I1 = 1
I2 = NQ - 1
I3 = 1
II = 2
ELSE
I1 = NQ - 1
I2 = 1
I3 = -1
II = NQ*( NQ+1 ) / 2 - 1
END IF
*
IF( LEFT ) THEN
NI = N
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) or H(i)' is applied to C(1:i,1:n)
*
MI = I
ELSE
*
* H(i) or H(i)' is applied to C(1:m,1:i)
*
NI = I
END IF
*
* Apply H(i) or H(i)'
*
IF( NOTRAN ) THEN
TAUI = TAU( I )
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
AII = AP( II )
AP( II ) = ONE
CALL ZLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, LDC,
$ WORK )
AP( II ) = AII
*
IF( FORWRD ) THEN
II = II + I + 2
ELSE
II = II - I - 1
END IF
10 CONTINUE
ELSE
*
* Q was determined by a call to ZHPTRD with UPLO = 'L'.
*
FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. NOTRAN )
*
IF( FORWRD ) THEN
I1 = 1
I2 = NQ - 1
I3 = 1
II = 2
ELSE
I1 = NQ - 1
I2 = 1
I3 = -1
II = NQ*( NQ+1 ) / 2 - 1
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 20 I = I1, I2, I3
AII = AP( II )
AP( II ) = ONE
IF( LEFT ) THEN
*
* H(i) or H(i)' is applied to C(i+1:m,1:n)
*
MI = M - I
IC = I + 1
ELSE
*
* H(i) or H(i)' is applied to C(1:m,i+1:n)
*
NI = N - I
JC = I + 1
END IF
*
* Apply H(i) or H(i)'
*
IF( NOTRAN ) THEN
TAUI = TAU( I )
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
CALL ZLARF( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, JC ),
$ LDC, WORK )
AP( II ) = AII
*
IF( FORWRD ) THEN
II = II + NQ - I + 1
ELSE
II = II - NQ + I - 2
END IF
20 CONTINUE
END IF
RETURN
*
* End of ZUPMTR
*
END
SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DTRTRI computes the inverse of a real upper or lower triangular
* matrix A.
*
* This is the Level 3 BLAS version of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': A is upper triangular;
* = 'L': A is lower triangular.
*
* DIAG (input) CHARACTER*1
* = 'N': A is non-unit triangular;
* = 'U': A is unit triangular.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the triangular matrix A. If UPLO = 'U', the
* leading N-by-N upper triangular part of the array A contains
* the upper triangular matrix, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading N-by-N lower triangular part of the array A contains
* the lower triangular matrix, and the strictly upper
* triangular part of A is not referenced. If DIAG = 'U', the
* diagonal elements of A are also not referenced and are
* assumed to be 1.
* On exit, the (triangular) inverse of the original matrix, in
* the same storage format.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
* matrix is singular and its inverse can not be computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J, JB, NB, NN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTRTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity if non-unit.
*
IF( NOUNIT ) THEN
DO 10 INFO = 1, N
IF( A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
INFO = 0
END IF
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
ELSE
*
* Use blocked code
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix
*
DO 20 J = 1, N, NB
JB = MIN( NB, N-J+1 )
*
* Compute rows 1:j-1 of current block column
*
CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
$ JB, ONE, A, LDA, A( 1, J ), LDA )
CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
$ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
*
* Compute inverse of current diagonal block
*
CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
20 CONTINUE
ELSE
*
* Compute inverse of lower triangular matrix
*
NN = ( ( N-1 ) / NB )*NB + 1
DO 30 J = NN, 1, -NB
JB = MIN( NB, N-J+1 )
IF( J+JB.LE.N ) THEN
*
* Compute rows j+jb:n of current block column
*
CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG,
$ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
$ A( J+JB, J ), LDA )
CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG,
$ N-J-JB+1, JB, -ONE, A( J, J ), LDA,
$ A( J+JB, J ), LDA )
END IF
*
* Compute inverse of current diagonal block
*
CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
30 CONTINUE
END IF
END IF
*
RETURN
*
* End of DTRTRI
*
END
SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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 ..
DOUBLE PRECISION SFMIN
INTEGER I, J, JP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
INTEGER IDAMAX
EXTERNAL DLAMCH, 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
*
* Compute machine safe minimum
*
SFMIN = DLAMCH('S')
*
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 ) THEN
IF( ABS(A( J, J )) .GE. SFMIN ) THEN
CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
ELSE
DO 20 I = 1, M-J
A( J+I, J ) = A( J+I, J ) / A( J, J )
20 CONTINUE
END IF
END IF
*
ELSE IF( INFO.EQ.0 ) THEN
*
INFO = J
END IF
*
IF( J.LT.MIN( M, N ) ) THEN
*
* Update trailing submatrix.
*
CALL 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
SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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 (K2*abs(INCX))
* The vector of pivot indices. Only the elements in positions
* K1 through K2 of IPIV are accessed.
* IPIV(K) = L implies rows K and L are to be interchanged.
*
* INCX (input) INTEGER
* The increment between successive values of IPIV. If IPIV
* is negative, the pivots are applied in reverse order.
*
* Further Details
* ===============
*
* Modified by
* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32
DOUBLE PRECISION TEMP
* ..
* .. Executable Statements ..
*
* Interchange row I with row IPIV(I) for each of rows K1 through K2.
*
IF( INCX.GT.0 ) THEN
IX0 = K1
I1 = K1
I2 = K2
INC = 1
ELSE IF( INCX.LT.0 ) THEN
IX0 = 1 + ( 1-K2 )*INCX
I1 = K2
I2 = K1
INC = -1
ELSE
RETURN
END IF
*
N32 = ( N / 32 )*32
IF( N32.NE.0 ) THEN
DO 30 J = 1, N32, 32
IX = IX0
DO 20 I = I1, I2, INC
IP = IPIV( IX )
IF( IP.NE.I ) THEN
DO 10 K = J, J + 31
TEMP = A( I, K )
A( I, K ) = A( IP, K )
A( IP, K ) = TEMP
10 CONTINUE
END IF
IX = IX + INCX
20 CONTINUE
30 CONTINUE
END IF
IF( N32.NE.N ) THEN
N32 = N32 + 1
IX = IX0
DO 50 I = I1, I2, INC
IP = IPIV( IX )
IF( IP.NE.I ) THEN
DO 40 K = N32, N
TEMP = A( I, K )
A( I, K ) = A( IP, K )
A( IP, K ) = TEMP
40 CONTINUE
END IF
IX = IX + INCX
50 CONTINUE
END IF
*
RETURN
*
* End of DLASWP
*
END
SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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
SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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
* ===============
*
* 09-29-06 - patch from
* Bobby Cheng, MathWorks
*
* Replace l.204 and l.372
* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
* by
* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*
* 01-01-96 - Based on modifications by
* J. Lewis, Boeing Computer Services Company
* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services
* Company
*
* 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 I, IMAX, J, JMAX, K, KK, KP, KSTEP
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
$ ROWMAX, T, WK, WKM1, WKP1
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
INTEGER IDAMAX
EXTERNAL LSAME, IDAMAX, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL 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 70
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) .OR. DISNAN(ABSAKK) ) THEN
*
* Column K is zero or contains a NaN: 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) )'
*
IF( K.GT.2 ) THEN
*
D12 = A( K-1, K )
D22 = A( K-1, K-1 ) / D12
D11 = A( K, K ) / D12
T = ONE / ( D11*D22-ONE )
D12 = T / D12
*
DO 30 J = K - 2, 1, -1
WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) )
WK = D12*( D22*A( J, K )-A( J, K-1 ) )
DO 20 I = J, 1, -1
A( I, J ) = A( I, J ) - A( I, K )*WK -
$ A( I, K-1 )*WKM1
20 CONTINUE
A( J, K ) = WK
A( J, K-1 ) = WKM1
30 CONTINUE
*
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
*
* 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
40 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 70
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) .OR. DISNAN(ABSAKK) ) THEN
*
* Column K is zero or contains a NaN: 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)'
*
D11 = ONE / A( K, K )
CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
$ A( K+1, K+1 ), LDA )
*
* Store L(k) in column K
*
CALL DSCAL( N-K, D11, A( K+1, K ), 1 )
END IF
ELSE
*
* 2-by-2 pivot block D(k)
*
IF( K.LT.N-1 ) THEN
*
* Perform a rank-2 update of A(k+2:n,k+2:n) as
*
* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))'
*
* where L(k) and L(k+1) are the k-th and (k+1)-th
* columns of L
*
D21 = A( K+1, K )
D11 = A( K+1, K+1 ) / D21
D22 = A( K, K ) / D21
T = ONE / ( D11*D22-ONE )
D21 = T / D21
*
DO 60 J = K + 2, N
*
WK = D21*( D11*A( J, K )-A( J, K+1 ) )
WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) )
*
DO 50 I = J, N
A( I, J ) = A( I, J ) - A( I, K )*WK -
$ A( I, K+1 )*WKP1
50 CONTINUE
*
A( J, K ) = WK
A( J, K+1 ) = WKP1
*
60 CONTINUE
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 40
*
END IF
*
70 CONTINUE
*
RETURN
*
* End of DSYTF2
*
END
DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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 consistent 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 (MAX(1,LWORK)),
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External 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
SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER TYPE
INTEGER INFO, KL, KU, LDA, M, N
DOUBLE PRECISION CFROM, CTO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DLASCL multiplies the M by N real matrix A by the real scalar
* CTO/CFROM. This is done without over/underflow as long as the final
* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
* A may be full, upper triangular, lower triangular, upper Hessenberg,
* or banded.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*1
* TYPE indices the storage type of the input matrix.
* = 'G': A is a full matrix.
* = 'L': A is a lower triangular matrix.
* = 'U': A is an upper triangular matrix.
* = 'H': A is an upper Hessenberg matrix.
* = 'B': A is a symmetric band matrix with lower bandwidth KL
* and upper bandwidth KU and with the only the lower
* half stored.
* = 'Q': A is a symmetric band matrix with lower bandwidth KL
* and upper bandwidth KU and with the only the upper
* half stored.
* = 'Z': A is a band matrix with lower bandwidth KL and upper
* bandwidth KU.
*
* KL (input) INTEGER
* The lower bandwidth of A. Referenced only if TYPE = 'B',
* 'Q' or 'Z'.
*
* KU (input) INTEGER
* The upper bandwidth of A. Referenced only if TYPE = 'B',
* 'Q' or 'Z'.
*
* CFROM (input) DOUBLE PRECISION
* CTO (input) DOUBLE PRECISION
* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
* without over/underflow if the final result CTO*A(I,J)/CFROM
* can be represented without over/underflow. CFROM must be
* nonzero.
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* The matrix to be multiplied by CTO/CFROM. See TYPE for the
* storage type.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* INFO (output) INTEGER
* 0 - successful exit
* <0 - if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
INTEGER I, ITYPE, J, K1, K2, K3, K4
DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH, DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
*
IF( LSAME( TYPE, 'G' ) ) THEN
ITYPE = 0
ELSE IF( LSAME( TYPE, 'L' ) ) THEN
ITYPE = 1
ELSE IF( LSAME( TYPE, 'U' ) ) THEN
ITYPE = 2
ELSE IF( LSAME( TYPE, 'H' ) ) THEN
ITYPE = 3
ELSE IF( LSAME( TYPE, 'B' ) ) THEN
ITYPE = 4
ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
ITYPE = 5
ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
ITYPE = 6
ELSE
ITYPE = -1
END IF
*
IF( ITYPE.EQ.-1 ) THEN
INFO = -1
ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
INFO = -4
ELSE IF( DISNAN(CTO) ) THEN
INFO = -5
ELSE IF( M.LT.0 ) THEN
INFO = -6
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
$ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
INFO = -7
ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
INFO = -9
ELSE IF( ITYPE.GE.4 ) THEN
IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
INFO = -2
ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
$ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
$ THEN
INFO = -3
ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
$ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
$ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
INFO = -9
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASCL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
CFROMC = CFROM
CTOC = CTO
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
IF( CFROM1.EQ.CFROMC ) THEN
! CFROMC is an inf. Multiply by a correctly signed zero for
! finite CTOC, or a NaN if CTOC is infinite.
MUL = CTOC / CFROMC
DONE = .TRUE.
CTO1 = CTOC
ELSE
CTO1 = CTOC / BIGNUM
IF( CTO1.EQ.CTOC ) THEN
! CTOC is either 0 or an inf. In both cases, CTOC itself
! serves as the correct multiplication factor.
MUL = CTOC
DONE = .TRUE.
CFROMC = ONE
ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
MUL = SMLNUM
DONE = .FALSE.
CFROMC = CFROM1
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
MUL = BIGNUM
DONE = .FALSE.
CTOC = CTO1
ELSE
MUL = CTOC / CFROMC
DONE = .TRUE.
END IF
END IF
*
IF( ITYPE.EQ.0 ) THEN
*
* Full matrix
*
DO 30 J = 1, N
DO 20 I = 1, M
A( I, J ) = A( I, J )*MUL
20 CONTINUE
30 CONTINUE
*
ELSE IF( ITYPE.EQ.1 ) THEN
*
* Lower triangular matrix
*
DO 50 J = 1, N
DO 40 I = J, M
A( I, J ) = A( I, J )*MUL
40 CONTINUE
50 CONTINUE
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Upper triangular matrix
*
DO 70 J = 1, N
DO 60 I = 1, MIN( J, M )
A( I, J ) = A( I, J )*MUL
60 CONTINUE
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Upper Hessenberg matrix
*
DO 90 J = 1, N
DO 80 I = 1, MIN( J+1, M )
A( I, J ) = A( I, J )*MUL
80 CONTINUE
90 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Lower half of a symmetric band matrix
*
K3 = KL + 1
K4 = N + 1
DO 110 J = 1, N
DO 100 I = 1, MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
100 CONTINUE
110 CONTINUE
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Upper half of a symmetric band matrix
*
K1 = KU + 2
K3 = KU + 1
DO 130 J = 1, N
DO 120 I = MAX( K1-J, 1 ), K3
A( I, J ) = A( I, J )*MUL
120 CONTINUE
130 CONTINUE
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Band matrix
*
K1 = KL + KU + 2
K2 = KL + 1
K3 = 2*KL + KU + 1
K4 = KL + KU + 1 + M
DO 150 J = 1, N
DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
140 CONTINUE
150 CONTINUE
*
END IF
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of DLASCL
*
END
SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= 1.
* For optimum performance LWORK >= N*NB, where NB is the
* optimal blocksize.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n-1) . . . H(2) H(1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a 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.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, 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' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size.
*
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NX = N
IWS = 1
IF( NB.GT.1 .AND. NB.LT.N ) THEN
*
* Determine when to cross over from blocked to unblocked code
* (last block is always handled by unblocked code).
*
NX = MAX( NB, ILAENV( 3, '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 = MAX( LWORK / LDWORK, 1 )
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 ) = LWKOPT
RETURN
*
* End of DSYTRD
*
END
SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSTEDC computes all eigenvalues and, optionally, eigenvectors of a
* symmetric tridiagonal matrix using the divide and conquer method.
* The eigenvectors of a full or band real symmetric matrix can also be
* found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
* matrix to tridiagonal form.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none. See DLAED3 for details.
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'I': Compute eigenvectors of tridiagonal matrix also.
* = 'V': Compute eigenvectors of original dense symmetric
* matrix also. On entry, Z contains the orthogonal
* matrix used to reduce the original matrix to
* tridiagonal form.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal 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 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 INFO = 0, then 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 COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1.
* If eigenvectors are desired, then LDZ >= max(1,N).
*
* WORK (workspace/output) 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 COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
* If COMPZ = 'V' and N > 1 then LWORK must be at least
* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
* where lg( N ) = smallest integer k such
* that 2**k >= N.
* If COMPZ = 'I' and N > 1 then LWORK must be at least
* ( 1 + 4*N + N**2 ).
* Note that for COMPZ = 'I' or 'V', then if N is less than or
* equal to the minimum divide size, usually 25, then LWORK need
* only be max(1,2*(N-1)).
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK.
* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
* If COMPZ = 'V' and N > 1 then LIWORK must be at least
* ( 6 + 6*N + 5*N*lg N ).
* If COMPZ = 'I' and N > 1 then LIWORK must be at least
* ( 3 + 5*N ).
* Note that for COMPZ = 'I' or 'V', then if N is less than or
* equal to the minimum divide size, usually 25, then LIWORK
* need only be 1.
*
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an eigenvalue while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,
$ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW
DOUBLE PRECISION EPS, ORGNRM, P, TINY
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT,
$ DSTEQR, DSTERF, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
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.EQ.0 ) THEN
*
* Compute the workspace requirements
*
SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 )
IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE IF( N.LE.SMLSIZ ) THEN
LIWMIN = 1
LWMIN = 2*( N - 1 )
ELSE
LGN = INT( LOG( DBLE( N ) )/LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( ICOMPZ.EQ.1 ) THEN
LWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
LIWMIN = 6 + 6*N + 5*N*LGN
ELSE IF( ICOMPZ.EQ.2 ) THEN
LWMIN = 1 + 4*N + N**2
LIWMIN = 3 + 5*N
END IF
END IF
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN
INFO = -8
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN
INFO = -10
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEDC', -INFO )
RETURN
ELSE IF (LQUERY) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 ) THEN
IF( ICOMPZ.NE.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* If the following conditional clause is removed, then the routine
* will use the Divide and Conquer routine to compute only the
* eigenvalues, which requires (3N + 3N**2) real workspace and
* (2 + 5N + 2N lg(N)) integer workspace.
* Since on many architectures DSTERF is much faster than any other
* algorithm for finding eigenvalues only, it is used here
* as the default. If the conditional clause is removed, then
* information on the size of workspace needs to be changed.
*
* If COMPZ = 'N', use DSTERF to compute the eigenvalues.
*
IF( ICOMPZ.EQ.0 ) THEN
CALL DSTERF( N, D, E, INFO )
GO TO 50
END IF
*
* If N is smaller than the minimum divide size (SMLSIZ+1), then
* solve the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
*
CALL DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
ELSE
*
* If COMPZ = 'V', the Z matrix must be stored elsewhere for later
* use.
*
IF( ICOMPZ.EQ.1 ) THEN
STOREZ = 1 + N*N
ELSE
STOREZ = 1
END IF
*
IF( ICOMPZ.EQ.2 ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
END IF
*
* Scale.
*
ORGNRM = DLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ GO TO 50
*
EPS = DLAMCH( 'Epsilon' )
*
START = 1
*
* while ( START <= N )
*
10 CONTINUE
IF( START.LE.N ) THEN
*
* Let FINISH be the position of the next subdiagonal entry
* such that E( FINISH ) <= TINY or FINISH = N if no such
* subdiagonal exists. The matrix identified by the elements
* between START and FINISH constitutes an independent
* sub-problem.
*
FINISH = START
20 CONTINUE
IF( FINISH.LT.N ) THEN
TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
$ SQRT( ABS( D( FINISH+1 ) ) )
IF( ABS( E( FINISH ) ).GT.TINY ) THEN
FINISH = FINISH + 1
GO TO 20
END IF
END IF
*
* (Sub) Problem determined. Compute its size and solve it.
*
M = FINISH - START + 1
IF( M.EQ.1 ) THEN
START = FINISH + 1
GO TO 10
END IF
IF( M.GT.SMLSIZ ) THEN
*
* Scale.
*
ORGNRM = DLANST( 'M', M, D( START ), E( START ) )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
$ INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
$ M-1, INFO )
*
IF( ICOMPZ.EQ.1 ) THEN
STRTRW = 1
ELSE
STRTRW = START
END IF
CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ),
$ Z( STRTRW, START ), LDZ, WORK( 1 ), N,
$ WORK( STOREZ ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
$ MOD( INFO, ( M+1 ) ) + START - 1
GO TO 50
END IF
*
* Scale back.
*
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
$ INFO )
*
ELSE
IF( ICOMPZ.EQ.1 ) THEN
*
* Since QR won't update a Z matrix which is larger than
* the length of D, we must solve the sub-problem in a
* workspace and then multiply back into Z.
*
CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M,
$ WORK( M*M+1 ), INFO )
CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ,
$ WORK( STOREZ ), N )
CALL DGEMM( 'N', 'N', N, M, M, ONE,
$ WORK( STOREZ ), N, WORK, M, ZERO,
$ Z( 1, START ), LDZ )
ELSE IF( ICOMPZ.EQ.2 ) THEN
CALL DSTEQR( 'I', M, D( START ), E( START ),
$ Z( START, START ), LDZ, WORK, INFO )
ELSE
CALL DSTERF( M, D( START ), E( START ), INFO )
END IF
IF( INFO.NE.0 ) THEN
INFO = START*( N+1 ) + FINISH
GO TO 50
END IF
END IF
*
START = FINISH + 1
GO TO 10
END IF
*
* endwhile
*
* If the problem split any number of times, then the eigenvalues
* will not be properly ordered. Here we permute the eigenvalues
* (and the associated eigenvectors) into ascending order.
*
IF( M.NE.N ) THEN
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL DLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 40 II = 2, N
I = II - 1
K = I
P = D( I )
DO 30 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
30 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
40 CONTINUE
END IF
END IF
END IF
*
50 CONTINUE
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of DSTEDC
*
END
SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, UPLO
INTEGER INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* 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/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If SIDE = 'L', LWORK >= max(1,N);
* if SIDE = 'R', LWORK >= max(1,M).
* For optimum performance LWORK >= N*NB if SIDE = 'L', and
* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
* blocksize.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, UPPER
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. 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' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.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 ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
IF( UPPER ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
ELSE
IF( LEFT ) THEN
NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
END IF
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMTR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
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
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORMTR
*
END
SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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
INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, ISPEC, LWORK, N
CHARACTER NAME*( * ), OPTS*( * )
*
* Purpose
* =======
*
* This program sets problem and machine dependent parameters
* useful for xHSEQR and its subroutines. It is called whenever
* ILAENV is called with 12 <= ISPEC <= 16
*
* Arguments
* =========
*
* ISPEC (input) integer scalar
* ISPEC specifies which tunable parameter IPARMQ should
* return.
*
* ISPEC=12: (INMIN) Matrices of order nmin or less
* are sent directly to xLAHQR, the implicit
* double shift QR algorithm. NMIN must be
* at least 11.
*
* ISPEC=13: (INWIN) Size of the deflation window.
* This is best set greater than or equal to
* the number of simultaneous shifts NS.
* Larger matrices benefit from larger deflation
* windows.
*
* ISPEC=14: (INIBL) Determines when to stop nibbling and
* invest in an (expensive) multi-shift QR sweep.
* If the aggressive early deflation subroutine
* finds LD converged eigenvalues from an order
* NW deflation window and LD.GT.(NW*NIBBLE)/100,
* then the next QR sweep is skipped and early
* deflation is applied immediately to the
* remaining active diagonal block. Setting
* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a
* multi-shift QR sweep whenever early deflation
* finds a converged eigenvalue. Setting
* IPARMQ(ISPEC=14) greater than or equal to 100
* prevents TTQRE from skipping a multi-shift
* QR sweep.
*
* ISPEC=15: (NSHFTS) The number of simultaneous shifts in
* a multi-shift QR iteration.
*
* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the
* following meanings.
* 0: During the multi-shift QR sweep,
* xLAQR5 does not accumulate reflections and
* does not use matrix-matrix multiply to
* update the far-from-diagonal matrix
* entries.
* 1: During the multi-shift QR sweep,
* xLAQR5 and/or xLAQRaccumulates reflections and uses
* matrix-matrix multiply to update the
* far-from-diagonal matrix entries.
* 2: During the multi-shift QR sweep.
* xLAQR5 accumulates reflections and takes
* advantage of 2-by-2 block structure during
* matrix-matrix multiplies.
* (If xTRMM is slower than xGEMM, then
* IPARMQ(ISPEC=16)=1 may be more efficient than
* IPARMQ(ISPEC=16)=2 despite the greater level of
* arithmetic work implied by the latter choice.)
*
* NAME (input) character string
* Name of the calling subroutine
*
* OPTS (input) character string
* This is a concatenation of the string arguments to
* TTQRE.
*
* N (input) integer scalar
* N is the order of the Hessenberg matrix H.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that H is already upper triangular
* in rows and columns 1:ILO-1 and IHI+1:N.
*
* LWORK (input) integer scalar
* The amount of workspace available.
*
* Further Details
* ===============
*
* Little is known about how best to choose these parameters.
* It is possible to use different values of the parameters
* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.
*
* It is probably best to choose different parameters for
* different matrices and different parameters at different
* times during the iteration, but this has not been
* implemented --- yet.
*
*
* The best choices of most of the parameters depend
* in an ill-understood way on the relative execution
* rate of xLAQR3 and xLAQR5 and on the nature of each
* particular eigenvalue problem. Experiment may be the
* only practical way to determine which choices are most
* effective.
*
* Following is a list of default values supplied by IPARMQ.
* These defaults may be adjusted in order to attain better
* performance in any particular computational environment.
*
* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.
* Default: 75. (Must be at least 11.)
*
* IPARMQ(ISPEC=13) Recommended deflation window size.
* This depends on ILO, IHI and NS, the
* number of simultaneous shifts returned
* by IPARMQ(ISPEC=15). The default for
* (IHI-ILO+1).LE.500 is NS. The default
* for (IHI-ILO+1).GT.500 is 3*NS/2.
*
* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14.
*
* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.
* a multi-shift QR iteration.
*
* If IHI-ILO+1 is ...
*
* greater than ...but less ... the
* or equal to ... than default is
*
* 0 30 NS = 2+
* 30 60 NS = 4+
* 60 150 NS = 10
* 150 590 NS = **
* 590 3000 NS = 64
* 3000 6000 NS = 128
* 6000 infinity NS = 256
*
* (+) By default matrices of this order are
* passed to the implicit double shift routine
* xLAHQR. See IPARMQ(ISPEC=12) above. These
* values of NS are used only in case of a rare
* xLAHQR failure.
*
* (**) The asterisks (**) indicate an ad-hoc
* function increasing from 10 to 64.
*
* IPARMQ(ISPEC=16) Select structured matrix multiply.
* (See ISPEC=16 above for details.)
* Default: 3.
*
* ================================================================
* .. Parameters ..
INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22
PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14,
$ ISHFTS = 15, IACC22 = 16 )
INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP
PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14,
$ NIBBLE = 14, KNWSWP = 500 )
REAL TWO
PARAMETER ( TWO = 2.0 )
* ..
* .. Local Scalars ..
INTEGER NH, NS
* ..
* .. Intrinsic Functions ..
INTRINSIC LOG, MAX, MOD, NINT, REAL
* ..
* .. Executable Statements ..
IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR.
$ ( ISPEC.EQ.IACC22 ) ) THEN
*
* ==== Set the number simultaneous shifts ====
*
NH = IHI - ILO + 1
NS = 2
IF( NH.GE.30 )
$ NS = 4
IF( NH.GE.60 )
$ NS = 10
IF( NH.GE.150 )
$ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) )
IF( NH.GE.590 )
$ NS = 64
IF( NH.GE.3000 )
$ NS = 128
IF( NH.GE.6000 )
$ NS = 256
NS = MAX( 2, NS-MOD( NS, 2 ) )
END IF
*
IF( ISPEC.EQ.INMIN ) THEN
*
*
* ===== Matrices of order smaller than NMIN get sent
* . to xLAHQR, the classic double shift algorithm.
* . This must be at least 11. ====
*
IPARMQ = NMIN
*
ELSE IF( ISPEC.EQ.INIBL ) THEN
*
* ==== INIBL: skip a multi-shift qr iteration and
* . whenever aggressive early deflation finds
* . at least (NIBBLE*(window size)/100) deflations. ====
*
IPARMQ = NIBBLE
*
ELSE IF( ISPEC.EQ.ISHFTS ) THEN
*
* ==== NSHFTS: The number of simultaneous shifts =====
*
IPARMQ = NS
*
ELSE IF( ISPEC.EQ.INWIN ) THEN
*
* ==== NW: deflation window size. ====
*
IF( NH.LE.KNWSWP ) THEN
IPARMQ = NS
ELSE
IPARMQ = 3*NS / 2
END IF
*
ELSE IF( ISPEC.EQ.IACC22 ) THEN
*
* ==== IACC22: Whether to accumulate reflections
* . before updating the far-from-diagonal elements
* . and whether to use 2-by-2 block structure while
* . doing it. A small amount of work could be saved
* . by making this choice dependent also upon the
* . NH=IHI-ILO+1.
*
IPARMQ = 0
IF( NS.GE.KACMIN )
$ IPARMQ = 1
IF( NS.GE.K22MIN )
$ IPARMQ = 2
*
ELSE
* ===== invalid value of ispec =====
IPARMQ = -1
*
END IF
*
* ==== End of IPARMQ ====
*
END
SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, N
DOUBLE PRECISION SCALE, SUMSQ
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* Purpose
* =======
*
* ZLASSQ returns the values scl and ssq such that
*
* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
*
* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is
* assumed to be at least unity and the value of ssq will then satisfy
*
* 1.0 .le. ssq .le. ( sumsq + 2*n ).
*
* scale is assumed to be non-negative and scl returns the value
*
* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
* i
*
* scale and sumsq must be supplied in SCALE and SUMSQ respectively.
* SCALE and SUMSQ are overwritten by scl and ssq respectively.
*
* The routine makes only one pass through the vector X.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of elements to be used from the vector X.
*
* X (input) COMPLEX*16 array, dimension (N)
* The vector x as described above.
* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
*
* INCX (input) INTEGER
* The increment between successive values of the vector X.
* INCX > 0.
*
* SCALE (input/output) DOUBLE PRECISION
* On entry, the value scale in the equation above.
* On exit, SCALE is overwritten with the value scl .
*
* SUMSQ (input/output) DOUBLE PRECISION
* On entry, the value sumsq in the equation above.
* On exit, SUMSQ is overwritten with the value ssq .
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER IX
DOUBLE PRECISION TEMP1
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG
* ..
* .. Executable Statements ..
*
IF( N.GT.0 ) THEN
DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
IF( DBLE( X( IX ) ).NE.ZERO ) THEN
TEMP1 = ABS( DBLE( X( IX ) ) )
IF( SCALE.LT.TEMP1 ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
SCALE = TEMP1
ELSE
SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
END IF
END IF
IF( DIMAG( X( IX ) ).NE.ZERO ) THEN
TEMP1 = ABS( DIMAG( X( IX ) ) )
IF( SCALE.LT.TEMP1 ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
SCALE = TEMP1
ELSE
SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
END IF
END IF
10 CONTINUE
END IF
*
RETURN
*
* End of ZLASSQ
*
END
SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, N
COMPLEX*16 ALPHA, TAU
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* Purpose
* =======
*
* ZLARFG generates a complex elementary reflector H of order n, such
* that
*
* H' * ( alpha ) = ( beta ), H' * H = I.
* ( x ) ( 0 )
*
* where alpha and beta are scalars, with beta real, and x is an
* (n-1)-element complex vector. H is represented in the form
*
* H = I - tau * ( 1 ) * ( 1 v' ) ,
* ( v )
*
* where tau is a complex scalar and v is a complex (n-1)-element
* vector. Note that H is not hermitian.
*
* If the elements of x are all zero and alpha is real, then tau = 0
* and H is taken to be the unit matrix.
*
* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the elementary reflector.
*
* ALPHA (input/output) COMPLEX*16
* On entry, the value alpha.
* On exit, it is overwritten with the value beta.
*
* X (input/output) COMPLEX*16 array, dimension
* (1+(N-2)*abs(INCX))
* On entry, the vector x.
* On exit, it is overwritten with the vector v.
*
* INCX (input) INTEGER
* The increment between elements of X. INCX > 0.
*
* TAU (output) COMPLEX*16
* The value tau.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2
COMPLEX*16 ZLADIV
EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN
* ..
* .. External Subroutines ..
EXTERNAL ZDSCAL, ZSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = DZNRM2( N-1, X, INCX )
ALPHR = DBLE( ALPHA )
ALPHI = DIMAG( ALPHA )
*
IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
RSAFMN = ONE / SAFMIN
*
KNT = 0
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
10 CONTINUE
KNT = KNT + 1
CALL ZDSCAL( N-1, RSAFMN, X, INCX )
BETA = BETA*RSAFMN
ALPHI = ALPHI*RSAFMN
ALPHR = ALPHR*RSAFMN
IF( ABS( BETA ).LT.SAFMIN )
$ GO TO 10
*
* New BETA is at most 1, at least SAFMIN
*
XNORM = DZNRM2( N-1, X, INCX )
ALPHA = DCMPLX( ALPHR, ALPHI )
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
END IF
TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
CALL ZSCAL( N-1, ALPHA, X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
DO 20 J = 1, KNT
BETA = BETA*SAFMIN
20 CONTINUE
ALPHA = BETA
END IF
*
RETURN
*
* End of ZLARFG
*
END
DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
* Purpose
* =======
*
* DLANST 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 tridiagonal matrix A.
*
* Description
* ===========
*
* DLANST returns the value
*
* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'
* (
* ( norm1(A), NORM = '1', 'O' or 'o'
* (
* ( normI(A), NORM = 'I' or 'i'
* (
* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*
* where norm1 denotes the one norm of a matrix (maximum column sum),
* normI denotes the infinity norm of a matrix (maximum row sum) and
* normF denotes the Frobenius norm of a matrix (square root of sum of
* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANST as described
* above.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, DLANST is
* set to zero.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of A.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) sub-diagonal or super-diagonal elements of A.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION ANORM, SCALE, SUM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
ANORM = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
ANORM = ABS( D( N ) )
DO 10 I = 1, N - 1
ANORM = MAX( ANORM, ABS( D( I ) ) )
ANORM = MAX( ANORM, ABS( E( I ) ) )
10 CONTINUE
ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR.
$ LSAME( NORM, 'I' ) ) THEN
*
* Find norm1(A).
*
IF( N.EQ.1 ) THEN
ANORM = ABS( D( 1 ) )
ELSE
ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
$ ABS( E( N-1 ) )+ABS( D( N ) ) )
DO 20 I = 2, N - 1
ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+
$ ABS( E( I-1 ) ) )
20 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( N.GT.1 ) THEN
CALL DLASSQ( N-1, E, 1, SCALE, SUM )
SUM = 2*SUM
END IF
CALL DLASSQ( N, D, 1, SCALE, SUM )
ANORM = SCALE*SQRT( SUM )
END IF
*
DLANST = ANORM
RETURN
*
* End of DLANST
*
END
SUBROUTINE DLAE2( A, B, C, RT1, RT2 )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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) element of the 2-by-2 matrix.
*
* B (input) DOUBLE PRECISION
* The (1,2) and (2,1) elements of the 2-by-2 matrix.
*
* C (input) DOUBLE PRECISION
* The (2,2) element 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
DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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
SUBROUTINE DLASRT( ID, N, D, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER ID
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * )
* ..
*
* Purpose
* =======
*
* Sort the numbers in D in increasing order (if ID = 'I') or
* in decreasing order (if ID = 'D' ).
*
* Use Quick Sort, reverting to Insertion sort on arrays of
* size <= 20. Dimension of STACK limits N to about 2**32.
*
* Arguments
* =========
*
* ID (input) CHARACTER*1
* = 'I': sort D in increasing order;
* = 'D': sort D in decreasing order.
*
* N (input) INTEGER
* The length of the array D.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the array to be sorted.
* On exit, D has been sorted into increasing order
* (D(1) <= ... <= D(N) ) or into decreasing order
* (D(1) >= ... >= D(N) ), depending on ID.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
INTEGER SELECT
PARAMETER ( SELECT = 20 )
* ..
* .. Local Scalars ..
INTEGER DIR, ENDD, I, J, START, STKPNT
DOUBLE PRECISION D1, D2, D3, DMNMX, TMP
* ..
* .. Local Arrays ..
INTEGER STACK( 2, 32 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input paramters.
*
INFO = 0
DIR = -1
IF( LSAME( ID, 'D' ) ) THEN
DIR = 0
ELSE IF( LSAME( ID, 'I' ) ) THEN
DIR = 1
END IF
IF( DIR.EQ.-1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASRT', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
STKPNT = 1
STACK( 1, 1 ) = 1
STACK( 2, 1 ) = N
10 CONTINUE
START = STACK( 1, STKPNT )
ENDD = STACK( 2, STKPNT )
STKPNT = STKPNT - 1
IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
*
* Do Insertion sort on D( START:ENDD )
*
IF( DIR.EQ.0 ) THEN
*
* Sort into decreasing order
*
DO 30 I = START + 1, ENDD
DO 20 J = I, START + 1, -1
IF( D( J ).GT.D( J-1 ) ) THEN
DMNMX = D( J )
D( J ) = D( J-1 )
D( J-1 ) = DMNMX
ELSE
GO TO 30
END IF
20 CONTINUE
30 CONTINUE
*
ELSE
*
* Sort into increasing order
*
DO 50 I = START + 1, ENDD
DO 40 J = I, START + 1, -1
IF( D( J ).LT.D( J-1 ) ) THEN
DMNMX = D( J )
D( J ) = D( J-1 )
D( J-1 ) = DMNMX
ELSE
GO TO 50
END IF
40 CONTINUE
50 CONTINUE
*
END IF
*
ELSE IF( ENDD-START.GT.SELECT ) THEN
*
* Partition D( START:ENDD ) and stack parts, largest one first
*
* Choose partition entry as median of 3
*
D1 = D( START )
D2 = D( ENDD )
I = ( START+ENDD ) / 2
D3 = D( I )
IF( D1.LT.D2 ) THEN
IF( D3.LT.D1 ) THEN
DMNMX = D1
ELSE IF( D3.LT.D2 ) THEN
DMNMX = D3
ELSE
DMNMX = D2
END IF
ELSE
IF( D3.LT.D2 ) THEN
DMNMX = D2
ELSE IF( D3.LT.D1 ) THEN
DMNMX = D3
ELSE
DMNMX = D1
END IF
END IF
*
IF( DIR.EQ.0 ) THEN
*
* Sort into decreasing order
*
I = START - 1
J = ENDD + 1
60 CONTINUE
70 CONTINUE
J = J - 1
IF( D( J ).LT.DMNMX )
$ GO TO 70
80 CONTINUE
I = I + 1
IF( D( I ).GT.DMNMX )
$ GO TO 80
IF( I.LT.J ) THEN
TMP = D( I )
D( I ) = D( J )
D( J ) = TMP
GO TO 60
END IF
IF( J-START.GT.ENDD-J-1 ) THEN
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
ELSE
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
END IF
ELSE
*
* Sort into increasing order
*
I = START - 1
J = ENDD + 1
90 CONTINUE
100 CONTINUE
J = J - 1
IF( D( J ).GT.DMNMX )
$ GO TO 100
110 CONTINUE
I = I + 1
IF( D( I ).LT.DMNMX )
$ GO TO 110
IF( I.LT.J ) THEN
TMP = D( I )
D( I ) = D( J )
D( J ) = TMP
GO TO 90
END IF
IF( J-START.GT.ENDD-J-1 ) THEN
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
ELSE
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
END IF
END IF
END IF
IF( STKPNT.GT.0 )
$ GO TO 10
RETURN
*
* End of DLASRT
*
END
SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZUNG2L generates an m by n complex matrix Q with orthonormal columns,
* which is defined as the last n columns of a product of k elementary
* reflectors of order m
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by ZGEQLF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* On entry, the (n-k+i)-th column must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by ZGEQLF in the last k columns of its array
* argument A.
* On exit, the m-by-n matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) COMPLEX*16 array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by ZGEQLF.
*
* WORK (workspace) COMPLEX*16 array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument has an illegal value
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNG2L', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns 1:n-k to columns of the unit matrix
*
DO 20 J = 1, N - K
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( M-N+J, J ) = ONE
20 CONTINUE
*
DO 40 I = 1, K
II = N - K + I
*
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
*
A( M-N+II, II ) = ONE
CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
$ LDA, WORK )
CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
A( M-N+II, II ) = ONE - TAU( I )
*
* Set A(m-k+i+1:m,n-k+i) to zero
*
DO 30 L = M - N + II + 1, M
A( L, II ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of ZUNG2L
*
END
SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZUNG2R generates an m by n complex matrix Q with orthonormal columns,
* which is defined as the first n columns of a product of k elementary
* reflectors of order m
*
* Q = H(1) H(2) . . . H(k)
*
* as returned by ZGEQRF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* On entry, the i-th column must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by ZGEQRF in the first k columns of its array
* argument A.
* On exit, the m by n matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) COMPLEX*16 array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by ZGEQRF.
*
* WORK (workspace) COMPLEX*16 array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument has an illegal value
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNG2R', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns k+1:n to columns of the unit matrix
*
DO 20 J = K + 1, N
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( J, J ) = ONE
20 CONTINUE
*
DO 40 I = K, 1, -1
*
* Apply H(i) to A(i:m,i:n) from the left
*
IF( I.LT.N ) THEN
A( I, I ) = ONE
CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
$ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
A( I, I ) = ONE - TAU( I )
*
* Set A(1:i-1,i) to zero
*
DO 30 L = 1, I - 1
A( L, I ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of ZUNG2R
*
END
SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, M, N
COMPLEX*16 ALPHA, BETA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* Purpose
* =======
*
* ZLASET initializes a 2-D array A to BETA on the diagonal and
* ALPHA on the offdiagonals.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies the part of the matrix A to be set.
* = 'U': Upper triangular part is set. The lower triangle
* is unchanged.
* = 'L': Lower triangular part is set. The upper triangle
* is unchanged.
* Otherwise: All of the matrix A is set.
*
* M (input) INTEGER
* On entry, M specifies the number of rows of A.
*
* N (input) INTEGER
* On entry, N specifies the number of columns of A.
*
* ALPHA (input) COMPLEX*16
* All the offdiagonal array elements are set to ALPHA.
*
* BETA (input) COMPLEX*16
* All the diagonal array elements are set to BETA.
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* On entry, the m by n matrix A.
* On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;
* A(i,i) = BETA , 1 <= i <= min(m,n)
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Set the diagonal to BETA and the strictly upper triangular
* part of the array to ALPHA.
*
DO 20 J = 2, N
DO 10 I = 1, MIN( J-1, M )
A( I, J ) = ALPHA
10 CONTINUE
20 CONTINUE
DO 30 I = 1, MIN( N, M )
A( I, I ) = BETA
30 CONTINUE
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
*
* Set the diagonal to BETA and the strictly lower triangular
* part of the array to ALPHA.
*
DO 50 J = 1, MIN( M, N )
DO 40 I = J + 1, M
A( I, J ) = ALPHA
40 CONTINUE
50 CONTINUE
DO 60 I = 1, MIN( N, M )
A( I, I ) = BETA
60 CONTINUE
*
ELSE
*
* Set the array to BETA on the diagonal and ALPHA on the
* offdiagonal.
*
DO 80 J = 1, N
DO 70 I = 1, M
A( I, J ) = ALPHA
70 CONTINUE
80 CONTINUE
DO 90 I = 1, MIN( M, N )
A( I, I ) = BETA
90 CONTINUE
END IF
*
RETURN
*
* End of ZLASET
*
END
SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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) element of the 2-by-2 matrix.
*
* B (input) DOUBLE PRECISION
* The (1,2) element and the conjugate of the (2,1) element of
* the 2-by-2 matrix.
*
* C (input) DOUBLE PRECISION
* The (2,2) element 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
SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIRECT, PIVOT, SIDE
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * ), S( * )
COMPLEX*16 A( LDA, * )
* ..
*
* Purpose
* =======
*
* ZLASR applies a sequence of real plane rotations to a complex matrix
* A, from either the left or the right.
*
* When SIDE = 'L', the transformation takes the form
*
* A := P*A
*
* and when SIDE = 'R', the transformation takes the form
*
* A := A*P**T
*
* where P is an orthogonal matrix consisting of a sequence of z plane
* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
* and P**T is the transpose of P.
*
* When DIRECT = 'F' (Forward sequence), then
*
* P = P(z-1) * ... * P(2) * P(1)
*
* and when DIRECT = 'B' (Backward sequence), then
*
* P = P(1) * P(2) * ... * P(z-1)
*
* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
*
* R(k) = ( c(k) s(k) )
* = ( -s(k) c(k) ).
*
* When PIVOT = 'V' (Variable pivot), the rotation is performed
* for the plane (k,k+1), i.e., P(k) has the form
*
* P(k) = ( 1 )
* ( ... )
* ( 1 )
* ( c(k) s(k) )
* ( -s(k) c(k) )
* ( 1 )
* ( ... )
* ( 1 )
*
* where R(k) appears as a rank-2 modification to the identity matrix in
* rows and columns k and k+1.
*
* When PIVOT = 'T' (Top pivot), the rotation is performed for the
* plane (1,k+1), so P(k) has the form
*
* P(k) = ( c(k) s(k) )
* ( 1 )
* ( ... )
* ( 1 )
* ( -s(k) c(k) )
* ( 1 )
* ( ... )
* ( 1 )
*
* where R(k) appears in rows and columns 1 and k+1.
*
* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
* performed for the plane (k,z), giving P(k) the form
*
* P(k) = ( 1 )
* ( ... )
* ( 1 )
* ( c(k) s(k) )
* ( 1 )
* ( ... )
* ( 1 )
* ( -s(k) c(k) )
*
* where R(k) appears in rows and columns k and z. The rotations are
* performed without ever forming P(k) explicitly.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* Specifies whether the plane rotation matrix P is applied to
* A on the left or the right.
* = 'L': Left, compute A := P*A
* = 'R': Right, compute A:= A*P**T
*
* PIVOT (input) CHARACTER*1
* Specifies the plane for which P(k) is a plane rotation
* matrix.
* = 'V': Variable pivot, the plane (k,k+1)
* = 'T': Top pivot, the plane (1,k+1)
* = 'B': Bottom pivot, the plane (k,z)
*
* DIRECT (input) CHARACTER*1
* Specifies whether P is a forward or backward sequence of
* plane rotations.
* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)
* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)
*
* M (input) INTEGER
* The number of rows of the matrix A. If m <= 1, an immediate
* return is effected.
*
* N (input) INTEGER
* The number of columns of the matrix A. If n <= 1, an
* immediate return is effected.
*
* C (input) DOUBLE PRECISION array, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* The cosines c(k) of the plane rotations.
*
* S (input) DOUBLE PRECISION array, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* The sines s(k) of the plane rotations. The 2-by-2 plane
* rotation part of the matrix P(k), R(k), has the form
* R(k) = ( c(k) s(k) )
* ( -s(k) c(k) ).
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* The M-by-N matrix A. On exit, A is overwritten by P*A if
* SIDE = 'R' or by A*P**T if SIDE = 'L'.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
DOUBLE PRECISION CTEMP, STEMP
COMPLEX*16 TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
INFO = 1
ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
$ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
INFO = 2
ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
$ THEN
INFO = 3
ELSE IF( M.LT.0 ) THEN
INFO = 4
ELSE IF( N.LT.0 ) THEN
INFO = 5
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = 9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLASR ', INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
$ RETURN
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form P * A
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 20 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 10 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
10 CONTINUE
END IF
20 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 40 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 30 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
30 CONTINUE
END IF
40 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 60 J = 2, M
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 50 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
50 CONTINUE
END IF
60 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 80 J = M, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 70 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
70 CONTINUE
END IF
80 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 100 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 90 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
90 CONTINUE
END IF
100 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 120 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 110 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
110 CONTINUE
END IF
120 CONTINUE
END IF
END IF
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form A * P'
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 140 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 130 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
130 CONTINUE
END IF
140 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 160 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 150 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
150 CONTINUE
END IF
160 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 180 J = 2, N
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 170 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
170 CONTINUE
END IF
180 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 200 J = N, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 190 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
190 CONTINUE
END IF
200 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 220 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 210 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
210 CONTINUE
END IF
220 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 240 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 230 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
230 CONTINUE
END IF
240 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of ZLASR
*
END
SUBROUTINE DLARTG( F, G, CS, SN, R )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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 slower, more accurate version of the BLAS1 routine DROTG,
* with the following other 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).
*
* If F exceeds G in magnitude, CS will be positive.
*
* 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.
*
* This version has a few statements commented out for thread safety
* (machine parameters are computed on each entry). 10 feb 03, SJH.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
* ..
* .. Local Scalars ..
* LOGICAL FIRST
INTEGER COUNT, I
DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, SQRT
* ..
* .. Save statement ..
* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
* ..
* .. Data statements ..
* DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
* IF( FIRST ) THEN
SAFMIN = DLAMCH( 'S' )
EPS = DLAMCH( 'E' )
SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
$ LOG( DLAMCH( 'B' ) ) / TWO )
SAFMX2 = ONE / SAFMN2
* FIRST = .FALSE.
* END IF
IF( G.EQ.ZERO ) THEN
CS = ONE
SN = ZERO
R = F
ELSE IF( F.EQ.ZERO ) THEN
CS = ZERO
SN = ONE
R = G
ELSE
F1 = F
G1 = G
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.GE.SAFMX2 ) THEN
COUNT = 0
10 CONTINUE
COUNT = COUNT + 1
F1 = F1*SAFMN2
G1 = G1*SAFMN2
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.GE.SAFMX2 )
$ GO TO 10
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
DO 20 I = 1, COUNT
R = R*SAFMX2
20 CONTINUE
ELSE IF( SCALE.LE.SAFMN2 ) THEN
COUNT = 0
30 CONTINUE
COUNT = COUNT + 1
F1 = F1*SAFMX2
G1 = G1*SAFMX2
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.LE.SAFMN2 )
$ GO TO 30
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
DO 40 I = 1, COUNT
R = R*SAFMN2
40 CONTINUE
ELSE
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
END IF
IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
CS = -CS
SN = -SN
R = -R
END IF
END IF
RETURN
*
* End of DLARTG
*
END
SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDW, N, NB
* ..
* .. Array Arguments ..
DOUBLE PRECISION E( * )
COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * )
* ..
*
* Purpose
* =======
*
* ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to
* Hermitian tridiagonal form by a unitary similarity
* transformation Q' * A * Q, and returns the matrices V and W which are
* needed to apply the transformation to the unreduced part of A.
*
* If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a
* matrix, of which the upper triangle is supplied;
* if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a
* matrix, of which the lower triangle is supplied.
*
* This is an auxiliary routine called by ZHETRD.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* Hermitian matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A.
*
* NB (input) INTEGER
* The number of rows and columns to be reduced.
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
* n-by-n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n-by-n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
* On exit:
* if UPLO = 'U', the last NB columns have been reduced to
* tridiagonal form, with the diagonal elements overwriting
* the diagonal elements of A; the elements above the diagonal
* with the array TAU, represent the unitary matrix Q as a
* product of elementary reflectors;
* if UPLO = 'L', the first NB columns have been reduced to
* tridiagonal form, with the diagonal elements overwriting
* the diagonal elements of A; the elements below the diagonal
* with the array TAU, represent the unitary matrix Q as a
* product of elementary reflectors.
* See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* E (output) DOUBLE PRECISION array, dimension (N-1)
* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
* elements of the last NB columns of the reduced matrix;
* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
* the first NB columns of the reduced matrix.
*
* TAU (output) COMPLEX*16 array, dimension (N-1)
* The scalar factors of the elementary reflectors, stored in
* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
* See Further Details.
*
* W (output) COMPLEX*16 array, dimension (LDW,NB)
* The n-by-nb matrix W required to update the unreduced part
* of A.
*
* LDW (input) INTEGER
* The leading dimension of the array W. LDW >= max(1,N).
*
* Further Details
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n) H(n-1) . . . H(n-nb+1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a complex scalar, and v is a complex vector with
* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
* and tau in TAU(i-1).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(nb).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a complex scalar, and v is a complex vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
* and tau in TAU(i).
*
* The elements of the vectors v together form the n-by-nb matrix V
* which is needed, with W, to apply the transformation to the unreduced
* part of the matrix, using a Hermitian rank-2k update of the form:
* A := A - V*W' - W*V'.
*
* The contents of A on exit are illustrated by the following examples
* with n = 5 and nb = 2:
*
* if UPLO = 'U': if UPLO = 'L':
*
* ( a a a v4 v5 ) ( d )
* ( a a v4 v5 ) ( 1 d )
* ( a 1 v5 ) ( v1 1 a )
* ( d 1 ) ( v1 v2 a a )
* ( d ) ( v1 v2 a a a )
*
* where d denotes a diagonal element of the reduced matrix, a denotes
* an element of the original matrix that is unchanged, and vi denotes
* an element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE, HALF
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ),
$ HALF = ( 0.5D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, IW
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Reduce last NB columns of upper triangle
*
DO 10 I = N, N - NB + 1, -1
IW = I - N + NB
IF( I.LT.N ) THEN
*
* Update A(1:i,i)
*
A( I, I ) = DBLE( A( I, I ) )
CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
$ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
$ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
A( I, I ) = DBLE( A( I, I ) )
END IF
IF( I.GT.1 ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(1:i-2,i)
*
ALPHA = A( I-1, I )
CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) )
E( I-1 ) = ALPHA
A( I-1, I ) = ONE
*
* Compute W(1:i-1,i)
*
CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
$ ZERO, W( 1, IW ), 1 )
IF( I.LT.N ) THEN
CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
$ W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO,
$ W( I+1, IW ), 1 )
CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
$ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
$ A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO,
$ W( I+1, IW ), 1 )
CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
$ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
END IF
CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1,
$ A( 1, I ), 1 )
CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
END IF
*
10 CONTINUE
ELSE
*
* Reduce first NB columns of lower triangle
*
DO 20 I = 1, NB
*
* Update A(i:n,i)
*
A( I, I ) = DBLE( A( I, I ) )
CALL ZLACGV( I-1, W( I, 1 ), LDW )
CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
CALL ZLACGV( I-1, W( I, 1 ), LDW )
CALL ZLACGV( I-1, A( I, 1 ), LDA )
CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
$ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
CALL ZLACGV( I-1, A( I, 1 ), LDA )
A( I, I ) = DBLE( A( I, I ) )
IF( I.LT.N ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:n,i)
*
ALPHA = A( I+1, I )
CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1,
$ TAU( I ) )
E( I ) = ALPHA
A( I+1, I ) = ONE
*
* Compute W(i+1:n,i)
*
CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
$ W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO,
$ W( 1, I ), 1 )
CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
$ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
$ W( 1, I ), 1 )
CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
$ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1,
$ A( I+1, I ), 1 )
CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
END IF
*
20 CONTINUE
END IF
*
RETURN
*
* End of ZLATRD
*
END
SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAU( * )
* ..
*
* Purpose
* =======
*
* ZHETD2 reduces a complex Hermitian matrix A to real symmetric
* tridiagonal form T by a unitary similarity transformation:
* Q' * A * Q = T.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* Hermitian matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
* n-by-n upper triangular part of A contains the upper
* triangular part of the matrix A, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n-by-n lower triangular part of A contains the lower
* triangular part of the matrix A, and the strictly upper
* triangular part of A is not referenced.
* On exit, if UPLO = 'U', the diagonal and first superdiagonal
* of A are overwritten by the corresponding elements of the
* tridiagonal matrix T, and the elements above the first
* superdiagonal, with the array TAU, represent the unitary
* matrix Q as a product of elementary reflectors; if UPLO
* = 'L', the diagonal and first subdiagonal of A are over-
* written by the corresponding elements of the tridiagonal
* matrix T, and the elements below the first subdiagonal, with
* the array TAU, represent the unitary matrix Q as a product
* of elementary reflectors. See Further Details.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* D (output) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of the tridiagonal matrix T:
* D(i) = A(i,i).
*
* E (output) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix T:
* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*
* TAU (output) COMPLEX*16 array, dimension (N-1)
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n-1) . . . H(2) H(1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a complex scalar, and v is a complex vector with
* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
* A(1:i-1,i+1), and tau in TAU(i).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(n-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a complex scalar, and v is a complex vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
* and tau in TAU(i).
*
* The contents of A on exit are illustrated by the following examples
* with n = 5:
*
* if UPLO = 'U': if UPLO = 'L':
*
* ( d e v2 v3 v4 ) ( d )
* ( d e v3 v4 ) ( e d )
* ( d e v4 ) ( v1 e d )
* ( d e ) ( v1 v2 e d )
* ( d ) ( v1 v2 v3 e d )
*
* where d and e denote diagonal and off-diagonal elements of T, and vi
* denotes an element of the vector defining H(i).
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO, HALF
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ),
$ HALF = ( 0.5D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
COMPLEX*16 ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHETD2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A
*
A( N, N ) = DBLE( A( N, N ) )
DO 10 I = N - 1, 1, -1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(1:i-1,i+1)
*
ALPHA = A( I, I+1 )
CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI )
E( I ) = ALPHA
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(1:i,1:i)
*
A( I, I+1 ) = ONE
*
* Compute x := tau * A * v storing x in TAU(1:i)
*
CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
$ TAU, 1 )
*
* Compute w := x - 1/2 * tau * (x'*v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 )
CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
$ LDA )
*
ELSE
A( I, I ) = DBLE( A( I, I ) )
END IF
A( I, I+1 ) = E( I )
D( I+1 ) = A( I+1, I+1 )
TAU( I ) = TAUI
10 CONTINUE
D( 1 ) = A( 1, 1 )
ELSE
*
* Reduce the lower triangle of A
*
A( 1, 1 ) = DBLE( A( 1, 1 ) )
DO 20 I = 1, N - 1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(i+2:n,i)
*
ALPHA = A( I+1, I )
CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI )
E( I ) = ALPHA
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(i+1:n,i+1:n)
*
A( I+1, I ) = ONE
*
* Compute x := tau * A * v storing y in TAU(i:n-1)
*
CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, TAU( I ), 1 )
*
* Compute w := x - 1/2 * tau * (x'*v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ),
$ 1 )
CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
$ A( I+1, I+1 ), LDA )
*
ELSE
A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) )
END IF
A( I+1, I ) = E( I )
D( I ) = A( I, I )
TAU( I ) = TAUI
20 CONTINUE
D( N ) = A( N, N )
END IF
*
RETURN
*
* End of ZHETD2
*
END
SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN,
$ EIGCNT, LCNT, RCNT, INFO )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER JOBT
INTEGER EIGCNT, INFO, LCNT, N, RCNT
DOUBLE PRECISION PIVMIN, VL, VU
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
* Purpose
* =======
*
* Find the number of eigenvalues of the symmetric tridiagonal matrix T
* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T
* if JOBT = 'L'.
*
* Arguments
* =========
*
* JOBT (input) CHARACTER*1
* = 'T': Compute Sturm count for matrix T.
* = 'L': Compute Sturm count for matrix L D L^T.
*
* N (input) INTEGER
* The order of the matrix. N > 0.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* The lower and upper bounds for the eigenvalues.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.
* JOBT = 'L': The N diagonal elements of the diagonal matrix D.
*
* E (input) DOUBLE PRECISION array, dimension (N)
* JOBT = 'T': The N-1 offdiagonal elements of the matrix T.
* JOBT = 'L': The N-1 offdiagonal elements of the matrix L.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence for T.
*
* EIGCNT (output) INTEGER
* The number of eigenvalues of the symmetric tridiagonal matrix T
* that are in the interval (VL,VU]
*
* LCNT (output) INTEGER
* RCNT (output) INTEGER
* The left and right negcounts of the interval.
*
* INFO (output) INTEGER
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I
LOGICAL MATT
DOUBLE PRECISION LPIVOT, RPIVOT, SL, SU, TMP, TMP2
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
INFO = 0
LCNT = 0
RCNT = 0
EIGCNT = 0
MATT = LSAME( JOBT, 'T' )
IF (MATT) THEN
* Sturm sequence count on T
LPIVOT = D( 1 ) - VL
RPIVOT = D( 1 ) - VU
IF( LPIVOT.LE.ZERO ) THEN
LCNT = LCNT + 1
ENDIF
IF( RPIVOT.LE.ZERO ) THEN
RCNT = RCNT + 1
ENDIF
DO 10 I = 1, N-1
TMP = E(I)**2
LPIVOT = ( D( I+1 )-VL ) - TMP/LPIVOT
RPIVOT = ( D( I+1 )-VU ) - TMP/RPIVOT
IF( LPIVOT.LE.ZERO ) THEN
LCNT = LCNT + 1
ENDIF
IF( RPIVOT.LE.ZERO ) THEN
RCNT = RCNT + 1
ENDIF
10 CONTINUE
ELSE
* Sturm sequence count on L D L^T
SL = -VL
SU = -VU
DO 20 I = 1, N - 1
LPIVOT = D( I ) + SL
RPIVOT = D( I ) + SU
IF( LPIVOT.LE.ZERO ) THEN
LCNT = LCNT + 1
ENDIF
IF( RPIVOT.LE.ZERO ) THEN
RCNT = RCNT + 1
ENDIF
TMP = E(I) * D(I) * E(I)
*
TMP2 = TMP / LPIVOT
IF( TMP2.EQ.ZERO ) THEN
SL = TMP - VL
ELSE
SL = SL*TMP2 - VL
END IF
*
TMP2 = TMP / RPIVOT
IF( TMP2.EQ.ZERO ) THEN
SU = TMP - VU
ELSE
SU = SU*TMP2 - VU
END IF
20 CONTINUE
LPIVOT = D( N ) + SL
RPIVOT = D( N ) + SU
IF( LPIVOT.LE.ZERO ) THEN
LCNT = LCNT + 1
ENDIF
IF( RPIVOT.LE.ZERO ) THEN
RCNT = RCNT + 1
ENDIF
ENDIF
EIGCNT = RCNT - LCNT
RETURN
*
* end of DLARRC
*
END
SUBROUTINE DLARRR( N, D, E, INFO )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER N, INFO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
*
* Purpose
* =======
*
* Perform tests to decide whether the symmetric tridiagonal matrix T
* warrants expensive computations which guarantee high relative accuracy
* in the eigenvalues.
*
* 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/output) DOUBLE PRECISION array, dimension (N)
* On entry, the first (N-1) entries contain the subdiagonal
* elements of the tridiagonal matrix T; E(N) is set to ZERO.
*
* INFO (output) INTEGER
* INFO = 0(default) : the matrix warrants computations preserving
* relative accuracy.
* INFO = 1 : the matrix warrants computations guaranteeing
* only absolute accuracy.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, RELCOND
PARAMETER ( ZERO = 0.0D0,
$ RELCOND = 0.999D0 )
* ..
* .. Local Scalars ..
INTEGER I
LOGICAL YESREL
DOUBLE PRECISION EPS, SAFMIN, SMLNUM, RMIN, TMP, TMP2,
$ OFFDIG, OFFDIG2
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* As a default, do NOT go for relative-accuracy preserving computations.
INFO = 1
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
RMIN = SQRT( SMLNUM )
* Tests for relative accuracy
*
* Test for scaled diagonal dominance
* Scale the diagonal entries to one and check whether the sum of the
* off-diagonals is less than one
*
* The sdd relative error bounds have a 1/(1- 2*x) factor in them,
* x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative
* accuracy is promised. In the notation of the code fragment below,
* 1/(1 - (OFFDIG + OFFDIG2)) is the condition number.
* We don't think it is worth going into "sdd mode" unless the relative
* condition number is reasonable, not 1/macheps.
* The threshold should be compatible with other thresholds used in the
* code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds
* to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000
* instead of the current OFFDIG + OFFDIG2 < 1
*
YESREL = .TRUE.
OFFDIG = ZERO
TMP = SQRT(ABS(D(1)))
IF (TMP.LT.RMIN) YESREL = .FALSE.
IF(.NOT.YESREL) GOTO 11
DO 10 I = 2, N
TMP2 = SQRT(ABS(D(I)))
IF (TMP2.LT.RMIN) YESREL = .FALSE.
IF(.NOT.YESREL) GOTO 11
OFFDIG2 = ABS(E(I-1))/(TMP*TMP2)
IF(OFFDIG+OFFDIG2.GE.RELCOND) YESREL = .FALSE.
IF(.NOT.YESREL) GOTO 11
TMP = TMP2
OFFDIG = OFFDIG2
10 CONTINUE
11 CONTINUE
IF( YESREL ) THEN
INFO = 0
RETURN
ELSE
ENDIF
*
*
* *** MORE TO BE IMPLEMENTED ***
*
*
* Test if the lower bidiagonal matrix L from T = L D L^T
* (zero shift facto) is well conditioned
*
*
* Test if the upper bidiagonal matrix U from T = U D U^T
* (zero shift facto) is well conditioned.
* In this case, the matrix needs to be flipped and, at the end
* of the eigenvector computation, the flip needs to be applied
* to the computed eigenvectors (and the support)
*
*
RETURN
*
* END OF DLARRR
*
END
SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2,
$ RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M,
$ W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN,
$ WORK, IWORK, INFO )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
*
* .. Scalar Arguments ..
CHARACTER RANGE
INTEGER IL, INFO, IU, M, N, NSPLIT
DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ),
$ INDEXW( * )
DOUBLE PRECISION D( * ), E( * ), E2( * ), GERS( * ),
$ W( * ),WERR( * ), WGAP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* To find the desired eigenvalues of a given real symmetric
* tridiagonal matrix T, DLARRE sets any "small" off-diagonal
* elements to zero, and for each unreduced block T_i, it finds
* (a) a suitable shift at one end of the block's spectrum,
* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
* (c) eigenvalues of each L_i D_i L_i^T.
* The representations and eigenvalues found are then used by
* DSTEMR to compute the eigenvectors of T.
* The accuracy varies depending on whether bisection is used to
* find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to
* conpute all and then discard any unwanted one.
* As an added benefit, DLARRE also outputs the n
* Gerschgorin intervals for the matrices L_i D_i L_i^T.
*
* 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.
*
* N (input) INTEGER
* The order of the matrix. N > 0.
*
* VL (input/output) DOUBLE PRECISION
* VU (input/output) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds for the eigenvalues.
* Eigenvalues less than or equal to VL, or greater than VU,
* will not be returned. VL < VU.
* If RANGE='I' or ='A', DLARRE computes bounds on the desired
* part of the spectrum.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the N diagonal elements of the tridiagonal
* matrix T.
* On exit, the N diagonal elements of the diagonal
* matrices D_i.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the first (N-1) entries contain the subdiagonal
* elements of the tridiagonal matrix T; E(N) need not be set.
* On exit, E contains the subdiagonal elements of the unit
* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
* 1 <= I <= NSPLIT, contain the base points sigma_i on output.
*
* E2 (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the first (N-1) entries contain the SQUARES of the
* subdiagonal elements of the tridiagonal matrix T;
* E2(N) need not be set.
* On exit, the entries E2( ISPLIT( I ) ),
* 1 <= I <= NSPLIT, have been set to zero
*
* RTOL1 (input) DOUBLE PRECISION
* RTOL2 (input) DOUBLE PRECISION
* Parameters for bisection.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
*
* SPLTOL (input) DOUBLE PRECISION
* The threshold for splitting.
*
* NSPLIT (output) INTEGER
* The number of blocks T splits into. 1 <= NSPLIT <= N.
*
* ISPLIT (output) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into blocks.
* The first block 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.
*
* M (output) INTEGER
* The total number of eigenvalues (of all L_i D_i L_i^T)
* found.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the eigenvalues. The
* eigenvalues of each of the blocks, L_i D_i L_i^T, are
* sorted in ascending order ( DLARRE may use the
* remaining N-M elements as workspace).
*
* WERR (output) DOUBLE PRECISION array, dimension (N)
* The error bound on the corresponding eigenvalue in W.
*
* WGAP (output) DOUBLE PRECISION array, dimension (N)
* The separation from the right neighbor eigenvalue in W.
* The gap is only with respect to the eigenvalues of the same block
* as each block has its own representation tree.
* Exception: at the right end of a block we store the left gap
*
* IBLOCK (output) INTEGER array, dimension (N)
* The indices of the blocks (submatrices) associated with the
* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
* W(i) belongs to the first block from the top, =2 if W(i)
* belongs to the second block, etc.
*
* INDEXW (output) INTEGER array, dimension (N)
* The indices of the eigenvalues within each block (submatrix);
* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
*
* GERS (output) DOUBLE PRECISION array, dimension (2*N)
* The N Gerschgorin intervals (the i-th Gerschgorin interval
* is (GERS(2*i-1), GERS(2*i)).
*
* PIVMIN (output) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence for T.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (5*N)
* Workspace.
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: A problem occured in DLARRE.
* < 0: One of the called subroutines signaled an internal problem.
* Needs inspection of the corresponding parameter IINFO
* for further information.
*
* =-1: Problem in DLARRD.
* = 2: No base representation could be found in MAXTRY iterations.
* Increasing MAXTRY and recompilation might be a remedy.
* =-3: Problem in DLARRB when computing the refined root
* representation for DLASQ2.
* =-4: Problem in DLARRB when preforming bisection on the
* desired part of the spectrum.
* =-5: Problem in DLASQ2.
* =-6: Problem in DLASQ2.
*
* Further Details
* The base representations are required to suffer very little
* element growth and consequently define all their eigenvalues to
* high relative accuracy.
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
$ MAXGROWTH, ONE, PERT, TWO, ZERO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, FOUR=4.0D0,
$ HNDRD = 100.0D0,
$ PERT = 8.0D0,
$ HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF,
$ MAXGROWTH = 64.0D0, FUDGE = 2.0D0 )
INTEGER MAXTRY, ALLRNG, INDRNG, VALRNG
PARAMETER ( MAXTRY = 6, ALLRNG = 1, INDRNG = 2,
$ VALRNG = 3 )
* ..
* .. Local Scalars ..
LOGICAL FORCEB, NOREP, USEDQD
INTEGER CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
$ IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
$ WBEGIN, WEND
DOUBLE PRECISION AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
$ EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL,
$ RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM,
$ TAU, TMP, TMP1
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH, LSAME
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLARNV, DLARRA, DLARRB, DLARRC, DLARRD,
$ DLASQ2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Decode RANGE
*
IF( LSAME( RANGE, 'A' ) ) THEN
IRANGE = ALLRNG
ELSE IF( LSAME( RANGE, 'V' ) ) THEN
IRANGE = VALRNG
ELSE IF( LSAME( RANGE, 'I' ) ) THEN
IRANGE = INDRNG
END IF
M = 0
* Get machine constants
SAFMIN = DLAMCH( 'S' )
EPS = DLAMCH( 'P' )
* Set parameters
RTL = SQRT(EPS)
BSRTOL = SQRT(EPS)
* Treat case of 1x1 matrix for quick return
IF( N.EQ.1 ) THEN
IF( (IRANGE.EQ.ALLRNG).OR.
$ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
$ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
M = 1
W(1) = D(1)
* The computation error of the eigenvalue is zero
WERR(1) = ZERO
WGAP(1) = ZERO
IBLOCK( 1 ) = 1
INDEXW( 1 ) = 1
GERS(1) = D( 1 )
GERS(2) = D( 1 )
ENDIF
* store the shift for the initial RRR, which is zero in this case
E(1) = ZERO
RETURN
END IF
* General case: tridiagonal matrix of order > 1
*
* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter.
* Compute maximum off-diagonal entry and pivmin.
GL = D(1)
GU = D(1)
EOLD = ZERO
EMAX = ZERO
E(N) = ZERO
DO 5 I = 1,N
WERR(I) = ZERO
WGAP(I) = ZERO
EABS = ABS( E(I) )
IF( EABS .GE. EMAX ) THEN
EMAX = EABS
END IF
TMP1 = EABS + EOLD
GERS( 2*I-1) = D(I) - TMP1
GL = MIN( GL, GERS( 2*I - 1))
GERS( 2*I ) = D(I) + TMP1
GU = MAX( GU, GERS(2*I) )
EOLD = EABS
5 CONTINUE
* The minimum pivot allowed in the Sturm sequence for T
PIVMIN = SAFMIN * MAX( ONE, EMAX**2 )
* Compute spectral diameter. The Gerschgorin bounds give an
* estimate that is wrong by at most a factor of SQRT(2)
SPDIAM = GU - GL
* Compute splitting points
CALL DLARRA( N, D, E, E2, SPLTOL, SPDIAM,
$ NSPLIT, ISPLIT, IINFO )
* Can force use of bisection instead of faster DQDS.
* Option left in the code for future multisection work.
FORCEB = .FALSE.
* Initialize USEDQD, DQDS should be used for ALLRNG unless someone
* explicitly wants bisection.
USEDQD = (( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB))
IF( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ) THEN
* Set interval [VL,VU] that contains all eigenvalues
VL = GL
VU = GU
ELSE
* We call DLARRD to find crude approximations to the eigenvalues
* in the desired range. In case IRANGE = INDRNG, we also obtain the
* interval (VL,VU] that contains all the wanted eigenvalues.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
* DLARRD needs a WORK of size 4*N, IWORK of size 3*N
CALL DLARRD( RANGE, 'B', N, VL, VU, IL, IU, GERS,
$ BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
$ MM, W, WERR, VL, VU, IBLOCK, INDEXW,
$ WORK, IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0
DO 14 I = MM+1,N
W( I ) = ZERO
WERR( I ) = ZERO
IBLOCK( I ) = 0
INDEXW( I ) = 0
14 CONTINUE
END IF
***
* Loop over unreduced blocks
IBEGIN = 1
WBEGIN = 1
DO 170 JBLK = 1, NSPLIT
IEND = ISPLIT( JBLK )
IN = IEND - IBEGIN + 1
* 1 X 1 block
IF( IN.EQ.1 ) THEN
IF( (IRANGE.EQ.ALLRNG).OR.( (IRANGE.EQ.VALRNG).AND.
$ ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
$ .OR. ( (IRANGE.EQ.INDRNG).AND.(IBLOCK(WBEGIN).EQ.JBLK))
$ ) THEN
M = M + 1
W( M ) = D( IBEGIN )
WERR(M) = ZERO
* The gap for a single block doesn't matter for the later
* algorithm and is assigned an arbitrary large value
WGAP(M) = ZERO
IBLOCK( M ) = JBLK
INDEXW( M ) = 1
WBEGIN = WBEGIN + 1
ENDIF
* E( IEND ) holds the shift for the initial RRR
E( IEND ) = ZERO
IBEGIN = IEND + 1
GO TO 170
END IF
*
* Blocks of size larger than 1x1
*
* E( IEND ) will hold the shift for the initial RRR, for now set it =0
E( IEND ) = ZERO
*
* Find local outer bounds GL,GU for the block
GL = D(IBEGIN)
GU = D(IBEGIN)
DO 15 I = IBEGIN , IEND
GL = MIN( GERS( 2*I-1 ), GL )
GU = MAX( GERS( 2*I ), GU )
15 CONTINUE
SPDIAM = GU - GL
IF(.NOT. ((IRANGE.EQ.ALLRNG).AND.(.NOT.FORCEB)) ) THEN
* Count the number of eigenvalues in the current block.
MB = 0
DO 20 I = WBEGIN,MM
IF( IBLOCK(I).EQ.JBLK ) THEN
MB = MB+1
ELSE
GOTO 21
ENDIF
20 CONTINUE
21 CONTINUE
IF( MB.EQ.0) THEN
* No eigenvalue in the current block lies in the desired range
* E( IEND ) holds the shift for the initial RRR
E( IEND ) = ZERO
IBEGIN = IEND + 1
GO TO 170
ELSE
* Decide whether dqds or bisection is more efficient
USEDQD = ( (MB .GT. FAC*IN) .AND. (.NOT.FORCEB) )
WEND = WBEGIN + MB - 1
* Calculate gaps for the current block
* In later stages, when representations for individual
* eigenvalues are different, we use SIGMA = E( IEND ).
SIGMA = ZERO
DO 30 I = WBEGIN, WEND - 1
WGAP( I ) = MAX( ZERO,
$ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
30 CONTINUE
WGAP( WEND ) = MAX( ZERO,
$ VU - SIGMA - (W( WEND )+WERR( WEND )))
* Find local index of the first and last desired evalue.
INDL = INDEXW(WBEGIN)
INDU = INDEXW( WEND )
ENDIF
ENDIF
IF(( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN
* Case of DQDS
* Find approximations to the extremal eigenvalues of the block
CALL DLARRK( IN, 1, GL, GU, D(IBEGIN),
$ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
ISLEFT = MAX(GL, TMP - TMP1
$ - HNDRD * EPS* ABS(TMP - TMP1))
CALL DLARRK( IN, IN, GL, GU, D(IBEGIN),
$ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
ISRGHT = MIN(GU, TMP + TMP1
$ + HNDRD * EPS * ABS(TMP + TMP1))
* Improve the estimate of the spectral diameter
SPDIAM = ISRGHT - ISLEFT
ELSE
* Case of bisection
* Find approximations to the wanted extremal eigenvalues
ISLEFT = MAX(GL, W(WBEGIN) - WERR(WBEGIN)
$ - HNDRD * EPS*ABS(W(WBEGIN)- WERR(WBEGIN) ))
ISRGHT = MIN(GU,W(WEND) + WERR(WEND)
$ + HNDRD * EPS * ABS(W(WEND)+ WERR(WEND)))
ENDIF
* Decide whether the base representation for the current block
* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I
* should be on the left or the right end of the current block.
* The strategy is to shift to the end which is "more populated"
* Furthermore, decide whether to use DQDS for the computation of
* the eigenvalue approximations at the end of DLARRE or bisection.
* dqds is chosen if all eigenvalues are desired or the number of
* eigenvalues to be computed is large compared to the blocksize.
IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
* If all the eigenvalues have to be computed, we use dqd
USEDQD = .TRUE.
* INDL is the local index of the first eigenvalue to compute
INDL = 1
INDU = IN
* MB = number of eigenvalues to compute
MB = IN
WEND = WBEGIN + MB - 1
* Define 1/4 and 3/4 points of the spectrum
S1 = ISLEFT + FOURTH * SPDIAM
S2 = ISRGHT - FOURTH * SPDIAM
ELSE
* DLARRD has computed IBLOCK and INDEXW for each eigenvalue
* approximation.
* choose sigma
IF( USEDQD ) THEN
S1 = ISLEFT + FOURTH * SPDIAM
S2 = ISRGHT - FOURTH * SPDIAM
ELSE
TMP = MIN(ISRGHT,VU) - MAX(ISLEFT,VL)
S1 = MAX(ISLEFT,VL) + FOURTH * TMP
S2 = MIN(ISRGHT,VU) - FOURTH * TMP
ENDIF
ENDIF
* Compute the negcount at the 1/4 and 3/4 points
IF(MB.GT.1) THEN
CALL DLARRC( 'T', IN, S1, S2, D(IBEGIN),
$ E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO)
ENDIF
IF(MB.EQ.1) THEN
SIGMA = GL
SGNDEF = ONE
ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN
IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
SIGMA = MAX(ISLEFT,GL)
ELSEIF( USEDQD ) THEN
* use Gerschgorin bound as shift to get pos def matrix
* for dqds
SIGMA = ISLEFT
ELSE
* use approximation of the first desired eigenvalue of the
* block as shift
SIGMA = MAX(ISLEFT,VL)
ENDIF
SGNDEF = ONE
ELSE
IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
SIGMA = MIN(ISRGHT,GU)
ELSEIF( USEDQD ) THEN
* use Gerschgorin bound as shift to get neg def matrix
* for dqds
SIGMA = ISRGHT
ELSE
* use approximation of the first desired eigenvalue of the
* block as shift
SIGMA = MIN(ISRGHT,VU)
ENDIF
SGNDEF = -ONE
ENDIF
* An initial SIGMA has been chosen that will be used for computing
* T - SIGMA I = L D L^T
* Define the increment TAU of the shift in case the initial shift
* needs to be refined to obtain a factorization with not too much
* element growth.
IF( USEDQD ) THEN
* The initial SIGMA was to the outer end of the spectrum
* the matrix is definite and we need not retreat.
TAU = SPDIAM*EPS*N + TWO*PIVMIN
ELSE
IF(MB.GT.1) THEN
CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN)
AVGAP = ABS(CLWDTH / DBLE(WEND-WBEGIN))
IF( SGNDEF.EQ.ONE ) THEN
TAU = HALF*MAX(WGAP(WBEGIN),AVGAP)
TAU = MAX(TAU,WERR(WBEGIN))
ELSE
TAU = HALF*MAX(WGAP(WEND-1),AVGAP)
TAU = MAX(TAU,WERR(WEND))
ENDIF
ELSE
TAU = WERR(WBEGIN)
ENDIF
ENDIF
*
DO 80 IDUM = 1, MAXTRY
* Compute L D L^T factorization of tridiagonal matrix T - sigma I.
* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of
* pivots in WORK(2*IN+1:3*IN)
DPIVOT = D( IBEGIN ) - SIGMA
WORK( 1 ) = DPIVOT
DMAX = ABS( WORK(1) )
J = IBEGIN
DO 70 I = 1, IN - 1
WORK( 2*IN+I ) = ONE / WORK( I )
TMP = E( J )*WORK( 2*IN+I )
WORK( IN+I ) = TMP
DPIVOT = ( D( J+1 )-SIGMA ) - TMP*E( J )
WORK( I+1 ) = DPIVOT
DMAX = MAX( DMAX, ABS(DPIVOT) )
J = J + 1
70 CONTINUE
* check for element growth
IF( DMAX .GT. MAXGROWTH*SPDIAM ) THEN
NOREP = .TRUE.
ELSE
NOREP = .FALSE.
ENDIF
IF( USEDQD .AND. .NOT.NOREP ) THEN
* Ensure the definiteness of the representation
* All entries of D (of L D L^T) must have the same sign
DO 71 I = 1, IN
TMP = SGNDEF*WORK( I )
IF( TMP.LT.ZERO ) NOREP = .TRUE.
71 CONTINUE
ENDIF
IF(NOREP) THEN
* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin
* shift which makes the matrix definite. So we should end up
* here really only in the case of IRANGE = VALRNG or INDRNG.
IF( IDUM.EQ.MAXTRY-1 ) THEN
IF( SGNDEF.EQ.ONE ) THEN
* The fudged Gerschgorin shift should succeed
SIGMA =
$ GL - FUDGE*SPDIAM*EPS*N - FUDGE*TWO*PIVMIN
ELSE
SIGMA =
$ GU + FUDGE*SPDIAM*EPS*N + FUDGE*TWO*PIVMIN
END IF
ELSE
SIGMA = SIGMA - SGNDEF * TAU
TAU = TWO * TAU
END IF
ELSE
* an initial RRR is found
GO TO 83
END IF
80 CONTINUE
* if the program reaches this point, no base representation could be
* found in MAXTRY iterations.
INFO = 2
RETURN
83 CONTINUE
* At this point, we have found an initial base representation
* T - SIGMA I = L D L^T with not too much element growth.
* Store the shift.
E( IEND ) = SIGMA
* Store D and L.
CALL DCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
CALL DCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
IF(MB.GT.1 ) THEN
*
* Perturb each entry of the base representation by a small
* (but random) relative amount to overcome difficulties with
* glued matrices.
*
DO 122 I = 1, 4
ISEED( I ) = 1
122 CONTINUE
CALL DLARNV(2, ISEED, 2*IN-1, WORK(1))
DO 125 I = 1,IN-1
D(IBEGIN+I-1) = D(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(I))
E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(IN+I))
125 CONTINUE
D(IEND) = D(IEND)*(ONE+EPS*FOUR*WORK(IN))
*
ENDIF
*
* Don't update the Gerschgorin intervals because keeping track
* of the updates would be too much work in DLARRV.
* We update W instead and use it to locate the proper Gerschgorin
* intervals.
* Compute the required eigenvalues of L D L' by bisection or dqds
IF ( .NOT.USEDQD ) THEN
* If DLARRD has been used, shift the eigenvalue approximations
* according to their representation. This is necessary for
* a uniform DLARRV since dqds computes eigenvalues of the
* shifted representation. In DLARRV, W will always hold the
* UNshifted eigenvalue approximation.
DO 134 J=WBEGIN,WEND
W(J) = W(J) - SIGMA
WERR(J) = WERR(J) + ABS(W(J)) * EPS
134 CONTINUE
* call DLARRB to reduce eigenvalue error of the approximations
* from DLARRD
DO 135 I = IBEGIN, IEND-1
WORK( I ) = D( I ) * E( I )**2
135 CONTINUE
* use bisection to find EV from INDL to INDU
CALL DLARRB(IN, D(IBEGIN), WORK(IBEGIN),
$ INDL, INDU, RTOL1, RTOL2, INDL-1,
$ W(WBEGIN), WGAP(WBEGIN), WERR(WBEGIN),
$ WORK( 2*N+1 ), IWORK, PIVMIN, SPDIAM,
$ IN, IINFO )
IF( IINFO .NE. 0 ) THEN
INFO = -4
RETURN
END IF
* DLARRB computes all gaps correctly except for the last one
* Record distance to VU/GU
WGAP( WEND ) = MAX( ZERO,
$ ( VU-SIGMA ) - ( W( WEND ) + WERR( WEND ) ) )
DO 138 I = INDL, INDU
M = M + 1
IBLOCK(M) = JBLK
INDEXW(M) = I
138 CONTINUE
ELSE
* Call dqds to get all eigs (and then possibly delete unwanted
* eigenvalues).
* Note that dqds finds the eigenvalues of the L D L^T representation
* of T to high relative accuracy. High relative accuracy
* might be lost when the shift of the RRR is subtracted to obtain
* the eigenvalues of T. However, T is not guaranteed to define its
* eigenvalues to high relative accuracy anyway.
* Set RTOL to the order of the tolerance used in DLASQ2
* This is an ESTIMATED error, the worst case bound is 4*N*EPS
* which is usually too large and requires unnecessary work to be
* done by bisection when computing the eigenvectors
RTOL = LOG(DBLE(IN)) * FOUR * EPS
J = IBEGIN
DO 140 I = 1, IN - 1
WORK( 2*I-1 ) = ABS( D( J ) )
WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 )
J = J + 1
140 CONTINUE
WORK( 2*IN-1 ) = ABS( D( IEND ) )
WORK( 2*IN ) = ZERO
CALL DLASQ2( IN, WORK, IINFO )
IF( IINFO .NE. 0 ) THEN
* If IINFO = -5 then an index is part of a tight cluster
* and should be changed. The index is in IWORK(1) and the
* gap is in WORK(N+1)
INFO = -5
RETURN
ELSE
* Test that all eigenvalues are positive as expected
DO 149 I = 1, IN
IF( WORK( I ).LT.ZERO ) THEN
INFO = -6
RETURN
ENDIF
149 CONTINUE
END IF
IF( SGNDEF.GT.ZERO ) THEN
DO 150 I = INDL, INDU
M = M + 1
W( M ) = WORK( IN-I+1 )
IBLOCK( M ) = JBLK
INDEXW( M ) = I
150 CONTINUE
ELSE
DO 160 I = INDL, INDU
M = M + 1
W( M ) = -WORK( I )
IBLOCK( M ) = JBLK
INDEXW( M ) = I
160 CONTINUE
END IF
DO 165 I = M - MB + 1, M
* the value of RTOL below should be the tolerance in DLASQ2
WERR( I ) = RTOL * ABS( W(I) )
165 CONTINUE
DO 166 I = M - MB + 1, M - 1
* compute the right gap between the intervals
WGAP( I ) = MAX( ZERO,
$ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
166 CONTINUE
WGAP( M ) = MAX( ZERO,
$ ( VU-SIGMA ) - ( W( M ) + WERR( M ) ) )
END IF
* proceed with next block
IBEGIN = IEND + 1
WBEGIN = WEND + 1
170 CONTINUE
*
RETURN
*
* end of DLARRE
*
END
SUBROUTINE ZLARRV( N, VL, VU, D, L, PIVMIN,
$ ISPLIT, M, DOL, DOU, MINRGP,
$ RTOL1, RTOL2, W, WERR, WGAP,
$ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ,
$ WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
*
* .. Scalar Arguments ..
INTEGER DOL, DOU, INFO, LDZ, M, N
DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
$ ISUPPZ( * ), IWORK( * )
DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
$ WGAP( * ), WORK( * )
COMPLEX*16 Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* ZLARRV computes the eigenvectors of the tridiagonal matrix
* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.
* The input eigenvalues should have been computed by DLARRE.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* Lower and upper bounds of the interval that contains the desired
* eigenvalues. VL < VU. Needed to compute gaps on the left or right
* end of the extremal eigenvalues in the desired RANGE.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the N diagonal elements of the diagonal matrix D.
* On exit, D may be overwritten.
*
* L (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the (N-1) subdiagonal elements of the unit
* bidiagonal matrix L are in elements 1 to N-1 of L
* (if the matrix is not splitted.) At the end of each block
* is stored the corresponding shift as given by DLARRE.
* On exit, L is overwritten.
*
* PIVMIN (in) DOUBLE PRECISION
* The minimum pivot allowed in the Sturm sequence.
*
* ISPLIT (input) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into blocks.
* The first block consists of rows/columns 1 to
* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
* through ISPLIT( 2 ), etc.
*
* M (input) INTEGER
* The total number of input eigenvalues. 0 <= M <= N.
*
* DOL (input) INTEGER
* DOU (input) INTEGER
* If the user wants to compute only selected eigenvectors from all
* the eigenvalues supplied, he can specify an index range DOL:DOU.
* Or else the setting DOL=1, DOU=M should be applied.
* Note that DOL and DOU refer to the order in which the eigenvalues
* are stored in W.
* If the user wants to compute only selected eigenpairs, then
* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
* computed eigenvectors. All other columns of Z are set to zero.
*
* MINRGP (input) DOUBLE PRECISION
*
* RTOL1 (input) DOUBLE PRECISION
* RTOL2 (input) DOUBLE PRECISION
* Parameters for bisection.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
*
* W (input/output) DOUBLE PRECISION array, dimension (N)
* The first M elements of W contain the APPROXIMATE 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 DLARRE is expected here ). Furthermore, they are with
* respect to the shift of the corresponding root representation
* for their block. On exit, W holds the eigenvalues of the
* UNshifted matrix.
*
* WERR (input/output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the semiwidth of the uncertainty
* interval of the corresponding eigenvalue in W
*
* WGAP (input/output) DOUBLE PRECISION array, dimension (N)
* The separation from the right neighbor eigenvalue in W.
*
* IBLOCK (input) INTEGER array, dimension (N)
* The indices of the blocks (submatrices) associated with the
* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
* W(i) belongs to the first block from the top, =2 if W(i)
* belongs to the second block, etc.
*
* INDEXW (input) INTEGER array, dimension (N)
* The indices of the eigenvalues within each block (submatrix);
* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
*
* GERS (input) DOUBLE PRECISION array, dimension (2*N)
* The N Gerschgorin intervals (the i-th Gerschgorin interval
* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
* be computed from the original UNshifted matrix.
*
* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )
* If INFO = 0, the first M columns of Z contain the
* orthonormal eigenvectors of the matrix T
* corresponding to the input eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The I-th eigenvector
* is nonzero only in elements ISUPPZ( 2*I-1 ) through
* ISUPPZ( 2*I ).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (12*N)
*
* IWORK (workspace) INTEGER array, dimension (7*N)
*
* INFO (output) INTEGER
* = 0: successful exit
*
* > 0: A problem occured in ZLARRV.
* < 0: One of the called subroutines signaled an internal problem.
* Needs inspection of the corresponding parameter IINFO
* for further information.
*
* =-1: Problem in DLARRB when refining a child's eigenvalues.
* =-2: Problem in DLARRF when computing the RRR of a child.
* When a child is inside a tight cluster, it can be difficult
* to find an RRR. A partial remedy from the user's point of
* view is to make the parameter MINRGP smaller and recompile.
* However, as the orthogonality of the computed vectors is
* proportional to 1/MINRGP, the user should be aware that
* he might be trading in precision when he decreases MINRGP.
* =-3: Problem in DLARRB when refining a single eigenvalue
* after the Rayleigh correction was rejected.
* = 5: The Rayleigh Quotient Iteration failed to converge to
* full accuracy in MAXITR steps.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXITR
PARAMETER ( MAXITR = 10 )
COMPLEX*16 CZERO
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, HALF
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, THREE = 3.0D0,
$ FOUR = 4.0D0, HALF = 0.5D0)
* ..
* .. Local Scalars ..
LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
$ IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG,
$ INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER,
$ ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS,
$ NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST,
$ NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST,
$ OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX,
$ WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU,
$ ZUSEDW
INTEGER INDIN1, INDIN2
DOUBLE PRECISION BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
$ LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID,
$ RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF,
$ SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLARRB, DLARRF, ZDSCAL, ZLAR1V,
$ ZLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
INTRINSIC DCMPLX
* ..
* .. Executable Statements ..
* ..
* The first N entries of WORK are reserved for the eigenvalues
INDLD = N+1
INDLLD= 2*N+1
INDIN1 = 3*N + 1
INDIN2 = 4*N + 1
INDWRK = 5*N + 1
MINWSIZE = 12 * N
DO 5 I= 1,MINWSIZE
WORK( I ) = ZERO
5 CONTINUE
* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the
* factorization used to compute the FP vector
IINDR = 0
* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current
* layer and the one above.
IINDC1 = N
IINDC2 = 2*N
IINDWK = 3*N + 1
MINIWSIZE = 7 * N
DO 10 I= 1,MINIWSIZE
IWORK( I ) = 0
10 CONTINUE
ZUSEDL = 1
IF(DOL.GT.1) THEN
* Set lower bound for use of Z
ZUSEDL = DOL-1
ENDIF
ZUSEDU = M
IF(DOU.LT.M) THEN
* Set lower bound for use of Z
ZUSEDU = DOU+1
ENDIF
* The width of the part of Z that is used
ZUSEDW = ZUSEDU - ZUSEDL + 1
CALL ZLASET( 'Full', N, ZUSEDW, CZERO, CZERO,
$ Z(1,ZUSEDL), LDZ )
EPS = DLAMCH( 'Precision' )
RQTOL = TWO * EPS
*
* Set expert flags for standard code.
TRYRQC = .TRUE.
IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
ELSE
* Only selected eigenpairs are computed. Since the other evalues
* are not refined by RQ iteration, bisection has to compute to full
* accuracy.
RTOL1 = FOUR * EPS
RTOL2 = FOUR * EPS
ENDIF
* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
* desired eigenvalues. The support of the nonzero eigenvector
* entries is contained in the interval IBEGIN:IEND.
* Remark that if k eigenpairs are desired, then the eigenvectors
* are stored in k contiguous columns of Z.
* DONE is the number of eigenvectors already computed
DONE = 0
IBEGIN = 1
WBEGIN = 1
DO 170 JBLK = 1, IBLOCK( M )
IEND = ISPLIT( JBLK )
SIGMA = L( IEND )
* Find the eigenvectors of the submatrix indexed IBEGIN
* through IEND.
WEND = WBEGIN - 1
15 CONTINUE
IF( WEND.LT.M ) THEN
IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN
WEND = WEND + 1
GO TO 15
END IF
END IF
IF( WEND.LT.WBEGIN ) THEN
IBEGIN = IEND + 1
GO TO 170
ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
IBEGIN = IEND + 1
WBEGIN = WEND + 1
GO TO 170
END IF
* Find local spectral diameter of the block
GL = GERS( 2*IBEGIN-1 )
GU = GERS( 2*IBEGIN )
DO 20 I = IBEGIN+1 , IEND
GL = MIN( GERS( 2*I-1 ), GL )
GU = MAX( GERS( 2*I ), GU )
20 CONTINUE
SPDIAM = GU - GL
* OLDIEN is the last index of the previous block
OLDIEN = IBEGIN - 1
* Calculate the size of the current block
IN = IEND - IBEGIN + 1
* The number of eigenvalues in the current block
IM = WEND - WBEGIN + 1
* This is for a 1x1 block
IF( IBEGIN.EQ.IEND ) THEN
DONE = DONE+1
Z( IBEGIN, WBEGIN ) = DCMPLX( ONE, ZERO )
ISUPPZ( 2*WBEGIN-1 ) = IBEGIN
ISUPPZ( 2*WBEGIN ) = IBEGIN
W( WBEGIN ) = W( WBEGIN ) + SIGMA
WORK( WBEGIN ) = W( WBEGIN )
IBEGIN = IEND + 1
WBEGIN = WBEGIN + 1
GO TO 170
END IF
* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND)
* Note that these can be approximations, in this case, the corresp.
* entries of WERR give the size of the uncertainty interval.
* The eigenvalue approximations will be refined when necessary as
* high relative accuracy is required for the computation of the
* corresponding eigenvectors.
CALL DCOPY( IM, W( WBEGIN ), 1,
& WORK( WBEGIN ), 1 )
* We store in W the eigenvalue approximations w.r.t. the original
* matrix T.
DO 30 I=1,IM
W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA
30 CONTINUE
* NDEPTH is the current depth of the representation tree
NDEPTH = 0
* PARITY is either 1 or 0
PARITY = 1
* NCLUS is the number of clusters for the next level of the
* representation tree, we start with NCLUS = 1 for the root
NCLUS = 1
IWORK( IINDC1+1 ) = 1
IWORK( IINDC1+2 ) = IM
* IDONE is the number of eigenvectors already computed in the current
* block
IDONE = 0
* loop while( IDONE.LT.IM )
* generate the representation tree for the current block and
* compute the eigenvectors
40 CONTINUE
IF( IDONE.LT.IM ) THEN
* This is a crude protection against infinitely deep trees
IF( NDEPTH.GT.M ) THEN
INFO = -2
RETURN
ENDIF
* breadth first processing of the current level of the representation
* tree: OLDNCL = number of clusters on current level
OLDNCL = NCLUS
* reset NCLUS to count the number of child clusters
NCLUS = 0
*
PARITY = 1 - PARITY
IF( PARITY.EQ.0 ) THEN
OLDCLS = IINDC1
NEWCLS = IINDC2
ELSE
OLDCLS = IINDC2
NEWCLS = IINDC1
END IF
* Process the clusters on the current level
DO 150 I = 1, OLDNCL
J = OLDCLS + 2*I
* OLDFST, OLDLST = first, last index of current cluster.
* cluster indices start with 1 and are relative
* to WBEGIN when accessing W, WGAP, WERR, Z
OLDFST = IWORK( J-1 )
OLDLST = IWORK( J )
IF( NDEPTH.GT.0 ) THEN
* Retrieve relatively robust representation (RRR) of cluster
* that has been computed at the previous level
* The RRR is stored in Z and overwritten once the eigenvectors
* have been computed or when the cluster is refined
IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
* Get representation from location of the leftmost evalue
* of the cluster
J = WBEGIN + OLDFST - 1
ELSE
IF(WBEGIN+OLDFST-1.LT.DOL) THEN
* Get representation from the left end of Z array
J = DOL - 1
ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN
* Get representation from the right end of Z array
J = DOU
ELSE
J = WBEGIN + OLDFST - 1
ENDIF
ENDIF
DO 45 K = 1, IN - 1
D( IBEGIN+K-1 ) = DBLE( Z( IBEGIN+K-1,
$ J ) )
L( IBEGIN+K-1 ) = DBLE( Z( IBEGIN+K-1,
$ J+1 ) )
45 CONTINUE
D( IEND ) = DBLE( Z( IEND, J ) )
SIGMA = DBLE( Z( IEND, J+1 ) )
* Set the corresponding entries in Z to zero
CALL ZLASET( 'Full', IN, 2, CZERO, CZERO,
$ Z( IBEGIN, J), LDZ )
END IF
* Compute DL and DLL of current RRR
DO 50 J = IBEGIN, IEND-1
TMP = D( J )*L( J )
WORK( INDLD-1+J ) = TMP
WORK( INDLLD-1+J ) = TMP*L( J )
50 CONTINUE
IF( NDEPTH.GT.0 ) THEN
* P and Q are index of the first and last eigenvalue to compute
* within the current block
P = INDEXW( WBEGIN-1+OLDFST )
Q = INDEXW( WBEGIN-1+OLDLST )
* Offset for the arrays WORK, WGAP and WERR, i.e., the P-OFFSET
* through the Q-OFFSET elements of these arrays are to be used.
C OFFSET = P-OLDFST
OFFSET = INDEXW( WBEGIN ) - 1
* perform limited bisection (if necessary) to get approximate
* eigenvalues to the precision needed.
CALL DLARRB( IN, D( IBEGIN ),
$ WORK(INDLLD+IBEGIN-1),
$ P, Q, RTOL1, RTOL2, OFFSET,
$ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
$ WORK( INDWRK ), IWORK( IINDWK ),
$ PIVMIN, SPDIAM, IN, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
* We also recompute the extremal gaps. W holds all eigenvalues
* of the unshifted matrix and must be used for computation
* of WGAP, the entries of WORK might stem from RRRs with
* different shifts. The gaps from WBEGIN-1+OLDFST to
* WBEGIN-1+OLDLST are correctly computed in DLARRB.
* However, we only allow the gaps to become greater since
* this is what should happen when we decrease WERR
IF( OLDFST.GT.1) THEN
WGAP( WBEGIN+OLDFST-2 ) =
$ MAX(WGAP(WBEGIN+OLDFST-2),
$ W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1)
$ - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) )
ENDIF
IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN
WGAP( WBEGIN+OLDLST-1 ) =
$ MAX(WGAP(WBEGIN+OLDLST-1),
$ W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST)
$ - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) )
ENDIF
* Each time the eigenvalues in WORK get refined, we store
* the newly found approximation with all shifts applied in W
DO 53 J=OLDFST,OLDLST
W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA
53 CONTINUE
END IF
* Process the current node.
NEWFST = OLDFST
DO 140 J = OLDFST, OLDLST
IF( J.EQ.OLDLST ) THEN
* we are at the right end of the cluster, this is also the
* boundary of the child cluster
NEWLST = J
ELSE IF ( WGAP( WBEGIN + J -1).GE.
$ MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN
* the right relative gap is big enough, the child cluster
* (NEWFST,..,NEWLST) is well separated from the following
NEWLST = J
ELSE
* inside a child cluster, the relative gap is not
* big enough.
GOTO 140
END IF
* Compute size of child cluster found
NEWSIZ = NEWLST - NEWFST + 1
* NEWFTT is the place in Z where the new RRR or the computed
* eigenvector is to be stored
IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
* Store representation at location of the leftmost evalue
* of the cluster
NEWFTT = WBEGIN + NEWFST - 1
ELSE
IF(WBEGIN+NEWFST-1.LT.DOL) THEN
* Store representation at the left end of Z array
NEWFTT = DOL - 1
ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN
* Store representation at the right end of Z array
NEWFTT = DOU
ELSE
NEWFTT = WBEGIN + NEWFST - 1
ENDIF
ENDIF
IF( NEWSIZ.GT.1) THEN
*
* Current child is not a singleton but a cluster.
* Compute and store new representation of child.
*
*
* Compute left and right cluster gap.
*
* LGAP and RGAP are not computed from WORK because
* the eigenvalue approximations may stem from RRRs
* different shifts. However, W hold all eigenvalues
* of the unshifted matrix. Still, the entries in WGAP
* have to be computed from WORK since the entries
* in W might be of the same order so that gaps are not
* exhibited correctly for very close eigenvalues.
IF( NEWFST.EQ.1 ) THEN
LGAP = MAX( ZERO,
$ W(WBEGIN)-WERR(WBEGIN) - VL )
ELSE
LGAP = WGAP( WBEGIN+NEWFST-2 )
ENDIF
RGAP = WGAP( WBEGIN+NEWLST-1 )
*
* Compute left- and rightmost eigenvalue of child
* to high precision in order to shift as close
* as possible and obtain as large relative gaps
* as possible
*
DO 55 K =1,2
IF(K.EQ.1) THEN
P = INDEXW( WBEGIN-1+NEWFST )
ELSE
P = INDEXW( WBEGIN-1+NEWLST )
ENDIF
OFFSET = INDEXW( WBEGIN ) - 1
CALL DLARRB( IN, D(IBEGIN),
$ WORK( INDLLD+IBEGIN-1 ),P,P,
$ RQTOL, RQTOL, OFFSET,
$ WORK(WBEGIN),WGAP(WBEGIN),
$ WERR(WBEGIN),WORK( INDWRK ),
$ IWORK( IINDWK ), PIVMIN, SPDIAM,
$ IN, IINFO )
55 CONTINUE
*
IF((WBEGIN+NEWLST-1.LT.DOL).OR.
$ (WBEGIN+NEWFST-1.GT.DOU)) THEN
* if the cluster contains no desired eigenvalues
* skip the computation of that branch of the rep. tree
*
* We could skip before the refinement of the extremal
* eigenvalues of the child, but then the representation
* tree could be different from the one when nothing is
* skipped. For this reason we skip at this place.
IDONE = IDONE + NEWLST - NEWFST + 1
GOTO 139
ENDIF
*
* Compute RRR of child cluster.
* Note that the new RRR is stored in Z
*
C DLARRF needs LWORK = 2*N
CALL DLARRF( IN, D( IBEGIN ), L( IBEGIN ),
$ WORK(INDLD+IBEGIN-1),
$ NEWFST, NEWLST, WORK(WBEGIN),
$ WGAP(WBEGIN), WERR(WBEGIN),
$ SPDIAM, LGAP, RGAP, PIVMIN, TAU,
$ WORK( INDIN1 ), WORK( INDIN2 ),
$ WORK( INDWRK ), IINFO )
* In the complex case, DLARRF cannot write
* the new RRR directly into Z and needs an intermediate
* workspace
DO 56 K = 1, IN-1
Z( IBEGIN+K-1, NEWFTT ) =
$ DCMPLX( WORK( INDIN1+K-1 ), ZERO )
Z( IBEGIN+K-1, NEWFTT+1 ) =
$ DCMPLX( WORK( INDIN2+K-1 ), ZERO )
56 CONTINUE
Z( IEND, NEWFTT ) =
$ DCMPLX( WORK( INDIN1+IN-1 ), ZERO )
IF( IINFO.EQ.0 ) THEN
* a new RRR for the cluster was found by DLARRF
* update shift and store it
SSIGMA = SIGMA + TAU
Z( IEND, NEWFTT+1 ) = DCMPLX( SSIGMA, ZERO )
* WORK() are the midpoints and WERR() the semi-width
* Note that the entries in W are unchanged.
DO 116 K = NEWFST, NEWLST
FUDGE =
$ THREE*EPS*ABS(WORK(WBEGIN+K-1))
WORK( WBEGIN + K - 1 ) =
$ WORK( WBEGIN + K - 1) - TAU
FUDGE = FUDGE +
$ FOUR*EPS*ABS(WORK(WBEGIN+K-1))
* Fudge errors
WERR( WBEGIN + K - 1 ) =
$ WERR( WBEGIN + K - 1 ) + FUDGE
* Gaps are not fudged. Provided that WERR is small
* when eigenvalues are close, a zero gap indicates
* that a new representation is needed for resolving
* the cluster. A fudge could lead to a wrong decision
* of judging eigenvalues 'separated' which in
* reality are not. This could have a negative impact
* on the orthogonality of the computed eigenvectors.
116 CONTINUE
NCLUS = NCLUS + 1
K = NEWCLS + 2*NCLUS
IWORK( K-1 ) = NEWFST
IWORK( K ) = NEWLST
ELSE
INFO = -2
RETURN
ENDIF
ELSE
*
* Compute eigenvector of singleton
*
ITER = 0
*
TOL = FOUR * LOG(DBLE(IN)) * EPS
*
K = NEWFST
WINDEX = WBEGIN + K - 1
WINDMN = MAX(WINDEX - 1,1)
WINDPL = MIN(WINDEX + 1,M)
LAMBDA = WORK( WINDEX )
DONE = DONE + 1
* Check if eigenvector computation is to be skipped
IF((WINDEX.LT.DOL).OR.
$ (WINDEX.GT.DOU)) THEN
ESKIP = .TRUE.
GOTO 125
ELSE
ESKIP = .FALSE.
ENDIF
LEFT = WORK( WINDEX ) - WERR( WINDEX )
RIGHT = WORK( WINDEX ) + WERR( WINDEX )
INDEIG = INDEXW( WINDEX )
* Note that since we compute the eigenpairs for a child,
* all eigenvalue approximations are w.r.t the same shift.
* In this case, the entries in WORK should be used for
* computing the gaps since they exhibit even very small
* differences in the eigenvalues, as opposed to the
* entries in W which might "look" the same.
IF( K .EQ. 1) THEN
* In the case RANGE='I' and with not much initial
* accuracy in LAMBDA and VL, the formula
* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
* can lead to an overestimation of the left gap and
* thus to inadequately early RQI 'convergence'.
* Prevent this by forcing a small left gap.
LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
ELSE
LGAP = WGAP(WINDMN)
ENDIF
IF( K .EQ. IM) THEN
* In the case RANGE='I' and with not much initial
* accuracy in LAMBDA and VU, the formula
* can lead to an overestimation of the right gap and
* thus to inadequately early RQI 'convergence'.
* Prevent this by forcing a small right gap.
RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
ELSE
RGAP = WGAP(WINDEX)
ENDIF
GAP = MIN( LGAP, RGAP )
IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN
* The eigenvector support can become wrong
* because significant entries could be cut off due to a
* large GAPTOL parameter in LAR1V. Prevent this.
GAPTOL = ZERO
ELSE
GAPTOL = GAP * EPS
ENDIF
ISUPMN = IN
ISUPMX = 1
* Update WGAP so that it holds the minimum gap
* to the left or the right. This is crucial in the
* case where bisection is used to ensure that the
* eigenvalue is refined up to the required precision.
* The correct value is restored afterwards.
SAVGAP = WGAP(WINDEX)
WGAP(WINDEX) = GAP
* We want to use the Rayleigh Quotient Correction
* as often as possible since it converges quadratically
* when we are close enough to the desired eigenvalue.
* However, the Rayleigh Quotient can have the wrong sign
* and lead us away from the desired eigenvalue. In this
* case, the best we can do is to use bisection.
USEDBS = .FALSE.
USEDRQ = .FALSE.
* Bisection is initially turned off unless it is forced
NEEDBS = .NOT.TRYRQC
120 CONTINUE
* Check if bisection should be used to refine eigenvalue
IF(NEEDBS) THEN
* Take the bisection as new iterate
USEDBS = .TRUE.
ITMP1 = IWORK( IINDR+WINDEX )
OFFSET = INDEXW( WBEGIN ) - 1
CALL DLARRB( IN, D(IBEGIN),
$ WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG,
$ ZERO, TWO*EPS, OFFSET,
$ WORK(WBEGIN),WGAP(WBEGIN),
$ WERR(WBEGIN),WORK( INDWRK ),
$ IWORK( IINDWK ), PIVMIN, SPDIAM,
$ ITMP1, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -3
RETURN
ENDIF
LAMBDA = WORK( WINDEX )
* Reset twist index from inaccurate LAMBDA to
* force computation of true MINGMA
IWORK( IINDR+WINDEX ) = 0
ENDIF
* Given LAMBDA, compute the eigenvector.
CALL ZLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ),
$ L( IBEGIN ), WORK(INDLD+IBEGIN-1),
$ WORK(INDLLD+IBEGIN-1),
$ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
$ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
$ IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ),
$ NRMINV, RESID, RQCORR, WORK( INDWRK ) )
IF(ITER .EQ. 0) THEN
BSTRES = RESID
BSTW = LAMBDA
ELSEIF(RESID.LT.BSTRES) THEN
BSTRES = RESID
BSTW = LAMBDA
ENDIF
ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 ))
ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX ))
ITER = ITER + 1
* sin alpha <= |resid|/gap
* Note that both the residual and the gap are
* proportional to the matrix, so ||T|| doesn't play
* a role in the quotient
*
* Convergence test for Rayleigh-Quotient iteration
* (omitted when Bisection has been used)
*
IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT.
$ RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS)
$ THEN
* We need to check that the RQCORR update doesn't
* move the eigenvalue away from the desired one and
* towards a neighbor. -> protection with bisection
IF(INDEIG.LE.NEGCNT) THEN
* The wanted eigenvalue lies to the left
SGNDEF = -ONE
ELSE
* The wanted eigenvalue lies to the right
SGNDEF = ONE
ENDIF
* We only use the RQCORR if it improves the
* the iterate reasonably.
IF( ( RQCORR*SGNDEF.GE.ZERO )
$ .AND.( LAMBDA + RQCORR.LE. RIGHT)
$ .AND.( LAMBDA + RQCORR.GE. LEFT)
$ ) THEN
USEDRQ = .TRUE.
* Store new midpoint of bisection interval in WORK
IF(SGNDEF.EQ.ONE) THEN
* The current LAMBDA is on the left of the true
* eigenvalue
LEFT = LAMBDA
* We prefer to assume that the error estimate
* is correct. We could make the interval not
* as a bracket but to be modified if the RQCORR
* chooses to. In this case, the RIGHT side should
* be modified as follows:
* RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
ELSE
* The current LAMBDA is on the right of the true
* eigenvalue
RIGHT = LAMBDA
* See comment about assuming the error estimate is
* correct above.
* LEFT = MIN(LEFT, LAMBDA + RQCORR)
ENDIF
WORK( WINDEX ) =
$ HALF * (RIGHT + LEFT)
* Take RQCORR since it has the correct sign and
* improves the iterate reasonably
LAMBDA = LAMBDA + RQCORR
* Update width of error interval
WERR( WINDEX ) =
$ HALF * (RIGHT-LEFT)
ELSE
NEEDBS = .TRUE.
ENDIF
IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN
* The eigenvalue is computed to bisection accuracy
* compute eigenvector and stop
USEDBS = .TRUE.
GOTO 120
ELSEIF( ITER.LT.MAXITR ) THEN
GOTO 120
ELSEIF( ITER.EQ.MAXITR ) THEN
NEEDBS = .TRUE.
GOTO 120
ELSE
INFO = 5
RETURN
END IF
ELSE
STP2II = .FALSE.
IF(USEDRQ .AND. USEDBS .AND.
$ BSTRES.LE.RESID) THEN
LAMBDA = BSTW
STP2II = .TRUE.
ENDIF
IF (STP2II) THEN
* improve error angle by second step
CALL ZLAR1V( IN, 1, IN, LAMBDA,
$ D( IBEGIN ), L( IBEGIN ),
$ WORK(INDLD+IBEGIN-1),
$ WORK(INDLLD+IBEGIN-1),
$ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
$ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
$ IWORK( IINDR+WINDEX ),
$ ISUPPZ( 2*WINDEX-1 ),
$ NRMINV, RESID, RQCORR, WORK( INDWRK ) )
ENDIF
WORK( WINDEX ) = LAMBDA
END IF
*
* Compute FP-vector support w.r.t. whole matrix
*
ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN
ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN
ZFROM = ISUPPZ( 2*WINDEX-1 )
ZTO = ISUPPZ( 2*WINDEX )
ISUPMN = ISUPMN + OLDIEN
ISUPMX = ISUPMX + OLDIEN
* Ensure vector is ok if support in the RQI has changed
IF(ISUPMN.LT.ZFROM) THEN
DO 122 II = ISUPMN,ZFROM-1
Z( II, WINDEX ) = ZERO
122 CONTINUE
ENDIF
IF(ISUPMX.GT.ZTO) THEN
DO 123 II = ZTO+1,ISUPMX
Z( II, WINDEX ) = ZERO
123 CONTINUE
ENDIF
CALL ZDSCAL( ZTO-ZFROM+1, NRMINV,
$ Z( ZFROM, WINDEX ), 1 )
125 CONTINUE
* Update W
W( WINDEX ) = LAMBDA+SIGMA
* Recompute the gaps on the left and right
* But only allow them to become larger and not
* smaller (which can only happen through "bad"
* cancellation and doesn't reflect the theory
* where the initial gaps are underestimated due
* to WERR being too crude.)
IF(.NOT.ESKIP) THEN
IF( K.GT.1) THEN
WGAP( WINDMN ) = MAX( WGAP(WINDMN),
$ W(WINDEX)-WERR(WINDEX)
$ - W(WINDMN)-WERR(WINDMN) )
ENDIF
IF( WINDEX.LT.WEND ) THEN
WGAP( WINDEX ) = MAX( SAVGAP,
$ W( WINDPL )-WERR( WINDPL )
$ - W( WINDEX )-WERR( WINDEX) )
ENDIF
ENDIF
IDONE = IDONE + 1
ENDIF
* here ends the code for the current child
*
139 CONTINUE
* Proceed to any remaining child nodes
NEWFST = J + 1
140 CONTINUE
150 CONTINUE
NDEPTH = NDEPTH + 1
GO TO 40
END IF
IBEGIN = IEND + 1
WBEGIN = WEND + 1
170 CONTINUE
*
RETURN
*
* End of ZLARRV
*
END
SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST,
$ RTOL, OFFSET, W, WERR, WORK, IWORK,
$ PIVMIN, SPDIAM, INFO )
*
* -- LAPACK auxiliary routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
*
* .. Scalar Arguments ..
INTEGER IFIRST, ILAST, INFO, N, OFFSET
DOUBLE PRECISION PIVMIN, RTOL, SPDIAM
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E2( * ), W( * ),
$ WERR( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* Given the initial eigenvalue approximations of T, DLARRJ
* does bisection to refine the eigenvalues of T,
* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
* guesses for these eigenvalues are input in W, the corresponding estimate
* of the error in these guesses in WERR. During bisection, intervals
* [left, right] are maintained by storing their mid-points and
* semi-widths in the arrays W and WERR respectively.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The N diagonal elements of T.
*
* E2 (input) DOUBLE PRECISION array, dimension (N-1)
* The Squares of the (N-1) subdiagonal elements of T.
*
* IFIRST (input) INTEGER
* The index of the first eigenvalue to be computed.
*
* ILAST (input) INTEGER
* The index of the last eigenvalue to be computed.
*
* RTOL (input) DOUBLE PRECISION
* Tolerance for the convergence of the bisection intervals.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).
*
* OFFSET (input) INTEGER
* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET
* through ILAST-OFFSET elements of these arrays are to be used.
*
* W (input/output) DOUBLE PRECISION array, dimension (N)
* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
* estimates of the eigenvalues of L D L^T indexed IFIRST through
* ILAST.
* On output, these estimates are refined.
*
* WERR (input/output) DOUBLE PRECISION array, dimension (N)
* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
* the errors in the estimates of the corresponding elements in W.
* On output, these errors are refined.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (2*N)
* Workspace.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence for T.
*
* SPDIAM (input) DOUBLE PRECISION
* The spectral diameter of T.
*
* INFO (output) INTEGER
* Error flag.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, HALF
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ HALF = 0.5D0 )
INTEGER MAXITR
* ..
* .. Local Scalars ..
INTEGER CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT,
$ OLNINT, P, PREV, SAVI1
DOUBLE PRECISION DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH
*
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
INFO = 0
*
MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
*
* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
* for an unconverged interval is set to the index of the next unconverged
* interval, and is -1 or 0 for a converged interval. Thus a linked
* list of unconverged intervals is set up.
*
I1 = IFIRST
I2 = ILAST
* The number of unconverged intervals
NINT = 0
* The last unconverged interval found
PREV = 0
DO 75 I = I1, I2
K = 2*I
II = I - OFFSET
LEFT = W( II ) - WERR( II )
MID = W(II)
RIGHT = W( II ) + WERR( II )
WIDTH = RIGHT - MID
TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
* The following test prevents the test of converged intervals
IF( WIDTH.LT.RTOL*TMP ) THEN
* This interval has already converged and does not need refinement.
* (Note that the gaps might change through refining the
* eigenvalues, however, they can only get bigger.)
* Remove it from the list.
IWORK( K-1 ) = -1
* Make sure that I1 always points to the first unconverged interval
IF((I.EQ.I1).AND.(I.LT.I2)) I1 = I + 1
IF((PREV.GE.I1).AND.(I.LE.I2)) IWORK( 2*PREV-1 ) = I + 1
ELSE
* unconverged interval found
PREV = I
* Make sure that [LEFT,RIGHT] contains the desired eigenvalue
*
* Do while( CNT(LEFT).GT.I-1 )
*
FAC = ONE
20 CONTINUE
CNT = 0
S = LEFT
DPLUS = D( 1 ) - S
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
DO 30 J = 2, N
DPLUS = D( J ) - S - E2( J-1 )/DPLUS
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
30 CONTINUE
IF( CNT.GT.I-1 ) THEN
LEFT = LEFT - WERR( II )*FAC
FAC = TWO*FAC
GO TO 20
END IF
*
* Do while( CNT(RIGHT).LT.I )
*
FAC = ONE
50 CONTINUE
CNT = 0
S = RIGHT
DPLUS = D( 1 ) - S
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
DO 60 J = 2, N
DPLUS = D( J ) - S - E2( J-1 )/DPLUS
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
60 CONTINUE
IF( CNT.LT.I ) THEN
RIGHT = RIGHT + WERR( II )*FAC
FAC = TWO*FAC
GO TO 50
END IF
NINT = NINT + 1
IWORK( K-1 ) = I + 1
IWORK( K ) = CNT
END IF
WORK( K-1 ) = LEFT
WORK( K ) = RIGHT
75 CONTINUE
SAVI1 = I1
*
* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
* and while (ITER.LT.MAXITR)
*
ITER = 0
80 CONTINUE
PREV = I1 - 1
I = I1
OLNINT = NINT
DO 100 P = 1, OLNINT
K = 2*I
II = I - OFFSET
NEXT = IWORK( K-1 )
LEFT = WORK( K-1 )
RIGHT = WORK( K )
MID = HALF*( LEFT + RIGHT )
* semiwidth of interval
WIDTH = RIGHT - MID
TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
IF( ( WIDTH.LT.RTOL*TMP ) .OR.
$ (ITER.EQ.MAXITR) )THEN
* reduce number of unconverged intervals
NINT = NINT - 1
* Mark interval as converged.
IWORK( K-1 ) = 0
IF( I1.EQ.I ) THEN
I1 = NEXT
ELSE
* Prev holds the last unconverged interval previously examined
IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
END IF
I = NEXT
GO TO 100
END IF
PREV = I
*
* Perform one bisection step
*
CNT = 0
S = MID
DPLUS = D( 1 ) - S
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
DO 90 J = 2, N
DPLUS = D( J ) - S - E2( J-1 )/DPLUS
IF( DPLUS.LT.ZERO ) CNT = CNT + 1
90 CONTINUE
IF( CNT.LE.I-1 ) THEN
WORK( K-1 ) = MID
ELSE
WORK( K ) = MID
END IF
I = NEXT
100 CONTINUE
ITER = ITER + 1
* do another loop if there are still unconverged intervals
* However, in the last iteration, all intervals are accepted
* since this is the best we can do.
IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
*
*
* At this point, all the intervals have converged
DO 110 I = SAVI1, ILAST
K = 2*I
II = I - OFFSET
* All intervals marked by '0' have been refined.
IF( IWORK( K-1 ).EQ.0 ) THEN
W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
WERR( II ) = WORK( K ) - W( II )
END IF
110 CONTINUE
*
RETURN
*
* End of DLARRJ
*
END
SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZUNMQL overwrites the general complex M-by-N matrix C with
*
* SIDE = 'L' SIDE = 'R'
* TRANS = 'N': Q * C C * Q
* TRANS = 'C': Q**H * C C * Q**H
*
* where Q is a complex unitary matrix defined as the product of k
* elementary reflectors
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N
* if SIDE = 'R'.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': apply Q or Q**H from the Left;
* = 'R': apply Q or Q**H from the Right.
*
* TRANS (input) CHARACTER*1
* = 'N': No transpose, apply Q;
* = 'C': Transpose, apply Q**H.
*
* M (input) INTEGER
* The number of rows of the matrix C. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix C. N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines
* the matrix Q.
* If SIDE = 'L', M >= K >= 0;
* if SIDE = 'R', N >= K >= 0.
*
* A (input) COMPLEX*16 array, dimension (LDA,K)
* The i-th column must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* ZGEQLF 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) COMPLEX*16 array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by ZGEQLF.
*
* C (input/output) COMPLEX*16 array, dimension (LDC,N)
* On entry, the M-by-N matrix C.
* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If SIDE = 'L', LWORK >= max(1,N);
* if SIDE = 'R', LWORK >= max(1,M).
* For optimum performance LWORK >= N*NB if SIDE = 'L', and
* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
* blocksize.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT,
$ MI, NB, NBMIN, NI, NQ, NW
* ..
* .. Local Arrays ..
COMPLEX*16 T( LDT, NBMAX )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2L
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, M )
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
LWKOPT = 1
ELSE
*
* 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, 'ZUNMQL', SIDE // TRANS, M, N,
$ K, -1 ) )
LWKOPT = NW*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMQL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RETURN
END IF
*
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, 'ZUNMQL', 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 ZUNM2L( 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 ZLARFT( '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 ZLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI,
$ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK,
$ LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMQL
*
END
SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZUNMQR overwrites the general complex M-by-N matrix C with
*
* SIDE = 'L' SIDE = 'R'
* TRANS = 'N': Q * C C * Q
* TRANS = 'C': Q**H * C C * Q**H
*
* where Q is a complex unitary matrix defined as the product of k
* elementary reflectors
*
* Q = H(1) H(2) . . . H(k)
*
* as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N
* if SIDE = 'R'.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': apply Q or Q**H from the Left;
* = 'R': apply Q or Q**H from the Right.
*
* TRANS (input) CHARACTER*1
* = 'N': No transpose, apply Q;
* = 'C': Conjugate transpose, apply Q**H.
*
* M (input) INTEGER
* The number of rows of the matrix C. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix C. N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines
* the matrix Q.
* If SIDE = 'L', M >= K >= 0;
* if SIDE = 'R', N >= K >= 0.
*
* A (input) COMPLEX*16 array, dimension (LDA,K)
* The i-th column must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* ZGEQRF in the first k columns of its array argument A.
* A is modified by the routine but restored on exit.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
* If SIDE = 'L', LDA >= max(1,M);
* if SIDE = 'R', LDA >= max(1,N).
*
* TAU (input) COMPLEX*16 array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by ZGEQRF.
*
* C (input/output) COMPLEX*16 array, dimension (LDC,N)
* On entry, the M-by-N matrix C.
* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If SIDE = 'L', LWORK >= max(1,N);
* if SIDE = 'R', LWORK >= max(1,M).
* For optimum performance LWORK >= N*NB if SIDE = 'L', and
* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
* blocksize.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
$ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
* ..
* .. Local Arrays ..
COMPLEX*16 T( LDT, NBMAX )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size. NB may be at most NBMAX, where NBMAX
* is used to define the local array T.
*
NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K,
$ -1 ) )
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMQR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
LDWORK = NW
IF( NB.GT.1 .AND. NB.LT.K ) THEN
IWS = NW*NB
IF( LWORK.LT.IWS ) THEN
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K,
$ -1 ) )
END IF
ELSE
IWS = NW
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* Use unblocked code
*
CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
$ IINFO )
ELSE
*
* Use blocked code
*
IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = NB
ELSE
I1 = ( ( K-1 ) / NB )*NB + 1
I2 = 1
I3 = -NB
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IB = MIN( NB, K-I+1 )
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
$ LDA, TAU( I ), T, LDT )
IF( LEFT ) THEN
*
* H or H' is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H or H' is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H or H'
*
CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI,
$ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC,
$ WORK, LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMQR
*
END
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 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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 .
*
* To avoid underflow, the matrix should be scaled so that its largest
* element 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.
*
* 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.
*
* 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.
*
* 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/output) 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 element 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
cccccc DIR NOVECTOR
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
*
cccccc PL CMCHAR=' '
cccccc DIR NEXTSCALAR
cccccc DIR SCALAR
cccccc DIR NEXT SCALAR
cccccc VD NOVECTOR
cccccc CDEC NOVECTOR
cccccc VD NOVECTOR
cccccc VDIR NOVECTOR
cccccc VOCL LOOP,SCALAR
cccccc IBM PREFER SCALAR
cccccc 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
SUBROUTINE DLARNV( IDIST, ISEED, N, X )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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.2831853071795864769252867663D+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
SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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) INTEGER
* = 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
SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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) INTEGER
* = 0 : successful exit
* .lt. 0: if INFO = -i, the i-th 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
SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER INCV, LDC, M, N
COMPLEX*16 TAU
* ..
* .. Array Arguments ..
COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZLARF applies a complex elementary reflector H to a complex M-by-N
* matrix C, from either the left or the right. H is represented in the
* form
*
* H = I - tau * v * v'
*
* where tau is a complex scalar and v is a complex vector.
*
* If tau = 0, then H is taken to be the unit matrix.
*
* To apply H' (the conjugate transpose of H), supply conjg(tau) instead
* tau.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': form H * C
* = 'R': form C * H
*
* M (input) INTEGER
* The number of rows of the matrix C.
*
* N (input) INTEGER
* The number of columns of the matrix C.
*
* V (input) COMPLEX*16 array, dimension
* (1 + (M-1)*abs(INCV)) if SIDE = 'L'
* or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
* The vector v in the representation of H. V is not used if
* TAU = 0.
*
* INCV (input) INTEGER
* The increment between elements of v. INCV <> 0.
*
* TAU (input) COMPLEX*16
* The value tau in the representation of H.
*
* C (input/output) COMPLEX*16 array, dimension (LDC,N)
* On entry, the M-by-N matrix C.
* On exit, C is overwritten by the matrix H * C if SIDE = 'L',
* or C * H if SIDE = 'R'.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace) COMPLEX*16 array, dimension
* (N) if SIDE = 'L'
* or (M) if SIDE = 'R'
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZGERC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAZLR, ILAZLC
EXTERNAL LSAME, ILAZLR, ILAZLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
LASTV = 0
LASTC = 0
IF( TAU.NE.ZERO ) THEN
! Set up variables for scanning V. LASTV begins pointing to the end
! of V.
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
IF( INCV.GT.0 ) THEN
I = 1 + (LASTV-1) * INCV
ELSE
I = 1
END IF
! Look for the last non-zero row in V.
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
LASTV = LASTV - 1
I = I - INCV
END DO
IF( APPLYLEFT ) THEN
! Scan for the last non-zero column in C(1:lastv,:).
LASTC = ILAZLC(LASTV, N, C, LDC)
ELSE
! Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILAZLR(M, LASTV, C, LDC)
END IF
END IF
! Note that lastc.eq.0 renders the BLAS operations null; no special
! case is needed at this level.
IF( APPLYLEFT ) THEN
*
* Form H * C
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1)
*
CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
$ C, LDC, V, INCV, ZERO, WORK, 1 )
*
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)'
*
CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
$ V, INCV, ZERO, WORK, 1 )
*
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)'
*
CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* End of ZLARF
*
END
SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DTRTI2 computes the inverse of a real upper or lower triangular
* matrix.
*
* This is the Level 2 BLAS version of the algorithm.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies whether the matrix A is upper or lower triangular.
* = 'U': Upper triangular
* = 'L': Lower triangular
*
* DIAG (input) CHARACTER*1
* Specifies whether or not the matrix A is unit triangular.
* = 'N': Non-unit triangular
* = 'U': Unit triangular
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the triangular matrix A. If UPLO = 'U', the
* leading n by n upper triangular part of the array A contains
* the upper triangular matrix, and the strictly lower
* triangular part of A is not referenced. If UPLO = 'L', the
* leading n by n lower triangular part of the array A contains
* the lower triangular matrix, and the strictly upper
* triangular part of A is not referenced. If DIAG = 'U', the
* diagonal elements of A are also not referenced and are
* assumed to be 1.
*
* On exit, the (triangular) inverse of the original matrix, in
* the same storage format.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -k, the k-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DTRMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTRTI2', -INFO )
RETURN
END IF
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix.
*
DO 10 J = 1, N
IF( NOUNIT ) THEN
A( J, J ) = ONE / A( J, J )
AJJ = -A( J, J )
ELSE
AJJ = -ONE
END IF
*
* Compute elements 1:j-1 of j-th column.
*
CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
$ A( 1, J ), 1 )
CALL DSCAL( J-1, AJJ, A( 1, J ), 1 )
10 CONTINUE
ELSE
*
* Compute inverse of lower triangular matrix.
*
DO 20 J = N, 1, -1
IF( NOUNIT ) THEN
A( J, J ) = ONE / A( J, J )
AJJ = -A( J, J )
ELSE
AJJ = -ONE
END IF
IF( J.LT.N ) THEN
*
* Compute elements j+1:n of j-th column.
*
CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J,
$ A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 )
END IF
20 CONTINUE
END IF
*
RETURN
*
* End of DTRTI2
*
END
LOGICAL FUNCTION DISNAN( DIN )
*
* -- LAPACK auxiliary routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
*
* .. Scalar Arguments ..
DOUBLE PRECISION DIN
* ..
*
* Purpose
* =======
*
* DISNAN returns .TRUE. if its argument is NaN, and .FALSE.
* otherwise. To be replaced by the Fortran 2003 intrinsic in the
* future.
*
* Arguments
* =========
*
* DIN (input) DOUBLE PRECISION
* Input to test for NaN.
*
* =====================================================================
*
* .. External Functions ..
LOGICAL DLAISNAN
EXTERNAL DLAISNAN
* ..
* .. Executable Statements ..
DISNAN = DLAISNAN(DIN,DIN)
RETURN
END
SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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 array, dimension (N)
* 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
SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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*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.
*
* 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
SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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
SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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 INFO = 0, then 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 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, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
$ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
$ NM1, NMAXIT
DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR,
$ DLASRT, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.EQ.2 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Determine the unit roundoff and over/underflow thresholds.
*
EPS = DLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues and eigenvectors of the tridiagonal
* matrix.
*
IF( ICOMPZ.EQ.2 )
$ CALL DLASET( 'Full', 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.EQ.ZERO )
$ GO TO 30
IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
END IF
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.EQ.ZERO )
$ GO TO 10
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GT.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
40 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 50 M = L, LENDM1
TST = ABS( E( M ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
$ SAFMIN )GO TO 60
50 CONTINUE
END IF
*
M = LEND
*
60 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 80
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
WORK( L ) = C
WORK( N-1+L ) = S
CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
END IF
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
END IF
*
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 140
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
90 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 100 M = L, LENDP1, -1
TST = ABS( E( M-1 ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
$ SAFMIN )GO TO 110
100 CONTINUE
END IF
*
M = LEND
*
110 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 130
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
WORK( M ) = C
WORK( N-1+M ) = S
CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
END IF
D( L-1 ) = RT1
D( L ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
END IF
*
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 140
*
END IF
*
* Undo scaling if necessary
*
140 CONTINUE
IF( ISCALE.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
ELSE IF( ISCALE.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
END IF
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.LT.NMAXIT )
$ GO TO 10
DO 150 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
150 CONTINUE
GO TO 190
*
* Order eigenvalues and eigenvectors.
*
160 CONTINUE
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL DLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 180 II = 2, N
I = II - 1
K = I
P = D( I )
DO 170 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
170 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
END IF
*
190 CONTINUE
RETURN
*
* End of DSTEQR
*
END
SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, M, N
DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DLASET initializes an m-by-n matrix A to BETA on the diagonal and
* ALPHA on the offdiagonals.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies the part of the matrix A to be set.
* = 'U': Upper triangular part is set; the strictly lower
* triangular part of A is not changed.
* = 'L': Lower triangular part is set; the strictly upper
* triangular part of A is not changed.
* Otherwise: All of the matrix A is set.
*
* 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 (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On exit, the leading m-by-n submatrix of A is set as follows:
*
* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,
* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,
* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,
*
* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Set the strictly upper triangular or trapezoidal part of the
* array to ALPHA.
*
DO 20 J = 2, N
DO 10 I = 1, MIN( J-1, M )
A( I, J ) = ALPHA
10 CONTINUE
20 CONTINUE
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
*
* Set the strictly lower triangular or trapezoidal part of the
* array to ALPHA.
*
DO 40 J = 1, MIN( M, N )
DO 30 I = J + 1, M
A( I, J ) = ALPHA
30 CONTINUE
40 CONTINUE
*
ELSE
*
* Set the leading m-by-n submatrix to ALPHA.
*
DO 60 J = 1, N
DO 50 I = 1, M
A( I, J ) = ALPHA
50 CONTINUE
60 CONTINUE
END IF
*
* Set the first min(M,N) diagonal elements to BETA.
*
DO 70 I = 1, MIN( M, N )
A( I, I ) = BETA
70 CONTINUE
*
RETURN
*
* End of DLASET
*
END
SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
$ WORK, IWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
$ WORK( * )
* ..
*
* Purpose
* =======
*
* DLAED0 computes all eigenvalues and corresponding eigenvectors of a
* symmetric tridiagonal matrix using the divide and conquer method.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
* = 2: Compute eigenvalues and eigenvectors of tridiagonal
* matrix.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the main diagonal of the tridiagonal matrix.
* On exit, its eigenvalues.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix.
* On exit, E has been destroyed.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* On entry, Q must contain an N-by-N orthogonal matrix.
* If ICOMPQ = 0 Q is not referenced.
* If ICOMPQ = 1 On entry, Q is a subset of the columns of the
* orthogonal matrix used to reduce the full
* matrix to tridiagonal form corresponding to
* the subset of the full matrix which is being
* decomposed at this time.
* If ICOMPQ = 2 On entry, Q will be the identity matrix.
* On exit, Q contains the eigenvectors of the
* tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. If eigenvectors are
* desired, then LDQ >= max(1,N). In any case, LDQ >= 1.
*
* QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N)
* Referenced only when ICOMPQ = 1. Used to store parts of
* the eigenvector matrix when the updating matrix multiplies
* take place.
*
* LDQS (input) INTEGER
* The leading dimension of the array QSTORE. If ICOMPQ = 1,
* then LDQS >= max(1,N). In any case, LDQS >= 1.
*
* WORK (workspace) DOUBLE PRECISION array,
* If ICOMPQ = 0 or 1, the dimension of WORK must be at least
* 1 + 3*N + 2*N*lg N + 2*N**2
* ( lg( N ) = smallest integer k
* such that 2^k >= N )
* If ICOMPQ = 2, the dimension of WORK must be at least
* 4*N + N**2.
*
* IWORK (workspace) INTEGER array,
* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
* 6 + 6*N + 5*N*lg N.
* ( lg( N ) = smallest integer k
* such that 2^k >= N )
* If ICOMPQ = 2, the dimension of IWORK must be at least
* 3 + 5*N.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: The algorithm failed to compute an eigenvalue while
* working on the submatrix lying in rows and columns
* INFO/(N+1) through mod(INFO,N+1).
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 )
* ..
* .. Local Scalars ..
INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
$ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
$ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
$ SPM2, SUBMAT, SUBPBS, TLVLS
DOUBLE PRECISION TEMP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR,
$ XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN
INFO = -1
ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED0', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 )
*
* Determine the size and placement of the submatrices, and save in
* the leading elements of IWORK.
*
IWORK( 1 ) = N
SUBPBS = 1
TLVLS = 0
10 CONTINUE
IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
DO 20 J = SUBPBS, 1, -1
IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
IWORK( 2*J-1 ) = IWORK( J ) / 2
20 CONTINUE
TLVLS = TLVLS + 1
SUBPBS = 2*SUBPBS
GO TO 10
END IF
DO 30 J = 2, SUBPBS
IWORK( J ) = IWORK( J ) + IWORK( J-1 )
30 CONTINUE
*
* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
* using rank-1 modifications (cuts).
*
SPM1 = SUBPBS - 1
DO 40 I = 1, SPM1
SUBMAT = IWORK( I ) + 1
SMM1 = SUBMAT - 1
D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
40 CONTINUE
*
INDXQ = 4*N + 3
IF( ICOMPQ.NE.2 ) THEN
*
* Set up workspaces for eigenvalues only/accumulate new vectors
* routine
*
TEMP = LOG( DBLE( N ) ) / LOG( TWO )
LGN = INT( TEMP )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IPRMPT = INDXQ + N + 1
IPERM = IPRMPT + N*LGN
IQPTR = IPERM + N*LGN
IGIVPT = IQPTR + N + 2
IGIVCL = IGIVPT + N*LGN
*
IGIVNM = 1
IQ = IGIVNM + 2*N*LGN
IWREM = IQ + N**2 + 1
*
* Initialize pointers
*
DO 50 I = 0, SUBPBS
IWORK( IPRMPT+I ) = 1
IWORK( IGIVPT+I ) = 1
50 CONTINUE
IWORK( IQPTR ) = 1
END IF
*
* Solve each submatrix eigenproblem at the bottom of the divide and
* conquer tree.
*
CURR = 0
DO 70 I = 0, SPM1
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 1 )
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+1 ) - IWORK( I )
END IF
IF( ICOMPQ.EQ.2 ) THEN
CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
IF( INFO.NE.0 )
$ GO TO 130
ELSE
CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 130
IF( ICOMPQ.EQ.1 ) THEN
CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,
$ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+
$ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),
$ LDQS )
END IF
IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
CURR = CURR + 1
END IF
K = 1
DO 60 J = SUBMAT, IWORK( I+1 )
IWORK( INDXQ+J ) = K
K = K + 1
60 CONTINUE
70 CONTINUE
*
* Successively merge eigensystems of adjacent submatrices
* into eigensystem for the corresponding larger matrix.
*
* while ( SUBPBS > 1 )
*
CURLVL = 1
80 CONTINUE
IF( SUBPBS.GT.1 ) THEN
SPM2 = SUBPBS - 2
DO 90 I = 0, SPM2, 2
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 2 )
MSD2 = IWORK( 1 )
CURPRB = 0
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+2 ) - IWORK( I )
MSD2 = MATSIZ / 2
CURPRB = CURPRB + 1
END IF
*
* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
* into an eigensystem of size MATSIZ.
* DLAED1 is used only for the full eigensystem of a tridiagonal
* matrix.
* DLAED7 handles the cases in which eigenvalues only or eigenvalues
* and eigenvectors of a full symmetric matrix (which was reduced to
* tridiagonal form) are desired.
*
IF( ICOMPQ.EQ.2 ) THEN
CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),
$ LDQ, IWORK( INDXQ+SUBMAT ),
$ E( SUBMAT+MSD2-1 ), MSD2, WORK,
$ IWORK( SUBPBS+1 ), INFO )
ELSE
CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,
$ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
$ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),
$ MSD2, WORK( IQ ), IWORK( IQPTR ),
$ IWORK( IPRMPT ), IWORK( IPERM ),
$ IWORK( IGIVPT ), IWORK( IGIVCL ),
$ WORK( IGIVNM ), WORK( IWREM ),
$ IWORK( SUBPBS+1 ), INFO )
END IF
IF( INFO.NE.0 )
$ GO TO 130
IWORK( I / 2+1 ) = IWORK( I+2 )
90 CONTINUE
SUBPBS = SUBPBS / 2
CURLVL = CURLVL + 1
GO TO 80
END IF
*
* end while
*
* Re-merge the eigenvalues/vectors which were deflated at the final
* merge step.
*
IF( ICOMPQ.EQ.1 ) THEN
DO 100 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
100 CONTINUE
CALL DCOPY( N, WORK, 1, D, 1 )
ELSE IF( ICOMPQ.EQ.2 ) THEN
DO 110 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
110 CONTINUE
CALL DCOPY( N, WORK, 1, D, 1 )
CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )
ELSE
DO 120 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
120 CONTINUE
CALL DCOPY( N, WORK, 1, D, 1 )
END IF
GO TO 140
*
130 CONTINUE
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
*
140 CONTINUE
RETURN
*
* End of DLAED0
*
END
SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* 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/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If SIDE = 'L', LWORK >= max(1,N);
* if SIDE = 'R', LWORK >= max(1,M).
* For optimum performance LWORK >= N*NB if SIDE = 'L', and
* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
* blocksize.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT,
$ 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' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, 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
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
LWKOPT = 1
ELSE
*
* 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 ) )
LWKOPT = NW*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMQL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RETURN
END IF
*
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 ) = LWKOPT
RETURN
*
* End of DORMQL
*
END
SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* 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/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK.
* If SIDE = 'L', LWORK >= max(1,N);
* if SIDE = 'R', LWORK >= max(1,M).
* For optimum performance LWORK >= N*NB if SIDE = 'L', and
* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
* blocksize.
*
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
$ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
* ..
* .. Local Arrays ..
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' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, '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 ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size. NB may be at most NBMAX, where NBMAX
* is used to define the local array T.
*
NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K,
$ -1 ) )
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMQR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
LDWORK = NW
IF( NB.GT.1 .AND. NB.LT.K ) THEN
IWS = NW*NB
IF( LWORK.LT.IWS ) THEN
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, '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 ) = LWKOPT
RETURN
*
* End of DORMQR
*
END
DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION X, Y, Z
* ..
*
* Purpose
* =======
*
* DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
* unnecessary overflow.
*
* Arguments
* =========
*
* X (input) DOUBLE PRECISION
* Y (input) DOUBLE PRECISION
* Z (input) DOUBLE PRECISION
* X, Y and Z specify the values x, y and z.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION W, XABS, YABS, ZABS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
XABS = ABS( X )
YABS = ABS( Y )
ZABS = ABS( Z )
W = MAX( XABS, YABS, ZABS )
IF( W.EQ.ZERO ) THEN
* W can be zero for max(0,nan,0)
* adding all three entries together will make sure
* NaN will not disappear.
DLAPY3 = XABS + YABS + ZABS
ELSE
DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
$ ( ZABS / W )**2 )
END IF
RETURN
*
* End of DLAPY3
*
END
COMPLEX*16 FUNCTION ZLADIV( X, Y )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
COMPLEX*16 X, Y
* ..
*
* Purpose
* =======
*
* ZLADIV := X / Y, where X and Y are complex. The computation of X / Y
* will not overflow on an intermediary step unless the results
* overflows.
*
* Arguments
* =========
*
* X (input) COMPLEX*16
* Y (input) COMPLEX*16
* The complex scalars X and Y.
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION ZI, ZR
* ..
* .. External Subroutines ..
EXTERNAL DLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DIMAG
* ..
* .. Executable Statements ..
*
CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR,
$ ZI )
ZLADIV = DCMPLX( ZR, ZI )
*
RETURN
*
* End of ZLADIV
*
END
SUBROUTINE ZLACGV( N, X, INCX )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, N
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* Purpose
* =======
*
* ZLACGV conjugates a complex vector of length N.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of the vector X. N >= 0.
*
* X (input/output) COMPLEX*16 array, dimension
* (1+(N-1)*abs(INCX))
* On entry, the vector of length N to be conjugated.
* On exit, X is overwritten with conjg(X).
*
* INCX (input) INTEGER
* The spacing between successive elements of X.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IOFF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
IF( INCX.EQ.1 ) THEN
DO 10 I = 1, N
X( I ) = DCONJG( X( I ) )
10 CONTINUE
ELSE
IOFF = 1
IF( INCX.LT.0 )
$ IOFF = 1 - ( N-1 )*INCX
DO 20 I = 1, N
X( IOFF ) = DCONJG( X( IOFF ) )
IOFF = IOFF + INCX
20 CONTINUE
END IF
RETURN
*
* End of ZLACGV
*
END
SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM,
$ NSPLIT, ISPLIT, INFO )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
*
* .. Scalar Arguments ..
INTEGER INFO, N, NSPLIT
DOUBLE PRECISION SPLTOL, TNRM
* ..
* .. Array Arguments ..
INTEGER ISPLIT( * )
DOUBLE PRECISION D( * ), E( * ), E2( * )
* ..
*
* Purpose
* =======
*
* Compute the splitting points with threshold SPLTOL.
* DLARRA sets any "small" off-diagonal elements to zero.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N > 0.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* On entry, the N diagonal elements of the tridiagonal
* matrix T.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the first (N-1) entries contain the subdiagonal
* elements of the tridiagonal matrix T; E(N) need not be set.
* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,
* are set to zero, the other entries of E are untouched.
*
* E2 (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the first (N-1) entries contain the SQUARES of the
* subdiagonal elements of the tridiagonal matrix T;
* E2(N) need not be set.
* On exit, the entries E2( ISPLIT( I ) ),
* 1 <= I <= NSPLIT, have been set to zero
*
* SPLTOL (input) DOUBLE PRECISION
* The threshold for splitting. Two criteria can be used:
* SPLTOL<0 : criterion based on absolute off-diagonal value
* SPLTOL>0 : criterion that preserves relative accuracy
*
* TNRM (input) DOUBLE PRECISION
* The norm of the matrix.
*
* NSPLIT (output) INTEGER
* The number of blocks T splits into. 1 <= NSPLIT <= N.
*
* ISPLIT (output) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into blocks.
* The first block 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.
*
*
* INFO (output) INTEGER
* = 0: successful exit
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION EABS, TMP1
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
INFO = 0
* Compute splitting points
NSPLIT = 1
IF(SPLTOL.LT.ZERO) THEN
* Criterion based on absolute off-diagonal value
TMP1 = ABS(SPLTOL)* TNRM
DO 9 I = 1, N-1
EABS = ABS( E(I) )
IF( EABS .LE. TMP1) THEN
E(I) = ZERO
E2(I) = ZERO
ISPLIT( NSPLIT ) = I
NSPLIT = NSPLIT + 1
END IF
9 CONTINUE
ELSE
* Criterion that guarantees relative accuracy
DO 10 I = 1, N-1
EABS = ABS( E(I) )
IF( EABS .LE. SPLTOL * SQRT(ABS(D(I)))*SQRT(ABS(D(I+1))) )
$ THEN
E(I) = ZERO
E2(I) = ZERO
ISPLIT( NSPLIT ) = I
NSPLIT = NSPLIT + 1
END IF
10 CONTINUE
ENDIF
ISPLIT( NSPLIT ) = N
RETURN
*
* End of DLARRA
*
END
SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS,
$ RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
$ M, W, WERR, WL, WU, IBLOCK, INDEXW,
$ WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.2.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* -- April 2009 --
*
* .. Scalar Arguments ..
CHARACTER ORDER, RANGE
INTEGER IL, INFO, IU, M, N, NSPLIT
DOUBLE PRECISION PIVMIN, RELTOL, VL, VU, WL, WU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), INDEXW( * ),
$ ISPLIT( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), E2( * ),
$ GERS( * ), W( * ), WERR( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLARRD computes the eigenvalues of a symmetric tridiagonal
* matrix T to suitable accuracy. This is an auxiliary code to be
* called from DSTEMR.
* The user may ask for all eigenvalues, all eigenvalues
* in the half-open interval (VL, VU], or the IL-th through IU-th
* eigenvalues.
*
* To avoid overflow, the matrix must be scaled so that its
* largest element 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.
*
* 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 order of the tridiagonal matrix T. N >= 0.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. Eigenvalues less than or equal
* to VL, or greater than VU, will not be returned. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* GERS (input) DOUBLE PRECISION array, dimension (2*N)
* The N Gerschgorin intervals (the i-th Gerschgorin interval
* is (GERS(2*i-1), GERS(2*i)).
*
* RELTOL (input) DOUBLE PRECISION
* The minimum relative width of an interval. When an interval
* is narrower 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.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) off-diagonal elements of the tridiagonal matrix T.
*
* E2 (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot allowed in the Sturm sequence for T.
*
* NSPLIT (input) INTEGER
* The number of diagonal blocks in the matrix T.
* 1 <= NSPLIT <= N.
*
* 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., 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.)
*
* M (output) INTEGER
* The actual number of eigenvalues found. 0 <= M <= N.
* (See also the description of INFO=2,3.)
*
* W (output) DOUBLE PRECISION array, dimension (N)
* On exit, the first M elements of W will contain the
* eigenvalue approximations. DLARRD computes an interval
* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue
* approximation is given as the interval midpoint
* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by
* WERR(j) = abs( a_j - b_j)/2
*
* WERR (output) DOUBLE PRECISION array, dimension (N)
* The error bound on the corresponding eigenvalue approximation
* in W.
*
* WL (output) DOUBLE PRECISION
* WU (output) DOUBLE PRECISION
* The interval (WL, WU] contains all the wanted eigenvalues.
* If RANGE='V', then WL=VL and WU=VU.
* If RANGE='A', then WL and WU are the global Gerschgorin bounds
* on the spectrum.
* If RANGE='I', then WL and WU are computed by DLAEBZ from the
* index range specified.
*
* 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, if INFO = 0, IBLOCK(i) specifies to which
* block (from 1 to the number of blocks) the eigenvalue W(i)
* belongs. (DLARRD may use the remaining N-M elements as
* workspace.)
*
* INDEXW (output) INTEGER array, dimension (N)
* The indices of the eigenvalues within each block (submatrix);
* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the
* i-th eigenvalue W(i) is the j-th eigenvalue in block k.
*
* 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
* ===================
*
* 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.
*
* Based on contributions by
* W. Kahan, University of California, Berkeley, USA
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, HALF, FUDGE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, HALF = ONE/TWO,
$ FUDGE = TWO )
INTEGER ALLRNG, VALRNG, INDRNG
PARAMETER ( ALLRNG = 1, VALRNG = 2, INDRNG = 3 )
* ..
* .. Local Scalars ..
LOGICAL NCNVRG, TOOFEW
INTEGER I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
$ IM, IN, IOFF, IOUT, IRANGE, ITMAX, ITMP1,
$ ITMP2, IW, IWOFF, J, JBLK, JDISC, JE, JEE, NB,
$ NWL, NWU
DOUBLE PRECISION ATOLI, EPS, GL, GU, RTOLI, TMP1, TMP2,
$ TNORM, UFLOW, WKILL, WLU, WUL
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, ILAENV, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLAEBZ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Decode RANGE
*
IF( LSAME( RANGE, 'A' ) ) THEN
IRANGE = ALLRNG
ELSE IF( LSAME( RANGE, 'V' ) ) THEN
IRANGE = VALRNG
ELSE IF( LSAME( RANGE, 'I' ) ) THEN
IRANGE = INDRNG
ELSE
IRANGE = 0
END IF
*
* Check for Errors
*
IF( IRANGE.LE.0 ) THEN
INFO = -1
ELSE IF( .NOT.(LSAME(ORDER,'B').OR.LSAME(ORDER,'E')) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( IRANGE.EQ.VALRNG ) THEN
IF( VL.GE.VU )
$ INFO = -5
ELSE IF( IRANGE.EQ.INDRNG .AND.
$ ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) THEN
INFO = -6
ELSE IF( IRANGE.EQ.INDRNG .AND.
$ ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
RETURN
END IF
* Initialize error flags
INFO = 0
NCNVRG = .FALSE.
TOOFEW = .FALSE.
* Quick return if possible
M = 0
IF( N.EQ.0 ) RETURN
* Simplification:
IF( IRANGE.EQ.INDRNG .AND. IL.EQ.1 .AND. IU.EQ.N ) IRANGE = 1
* Get machine constants
EPS = DLAMCH( 'P' )
UFLOW = DLAMCH( 'U' )
* Special Case when N=1
* Treat case of 1x1 matrix for quick return
IF( N.EQ.1 ) THEN
IF( (IRANGE.EQ.ALLRNG).OR.
$ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
$ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
M = 1
W(1) = D(1)
* The computation error of the eigenvalue is zero
WERR(1) = ZERO
IBLOCK( 1 ) = 1
INDEXW( 1 ) = 1
ENDIF
RETURN
END IF
* NB is the minimum vector length for vector bisection, or 0
* if only scalar is to be done.
NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 )
IF( NB.LE.1 ) NB = 0
* Find global spectral radius
GL = D(1)
GU = D(1)
DO 5 I = 1,N
GL = MIN( GL, GERS( 2*I - 1))
GU = MAX( GU, GERS(2*I) )
5 CONTINUE
* Compute global Gerschgorin bounds and spectral diameter
TNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
GU = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
* [JAN/28/2009] remove the line below since SPDIAM variable not use
* SPDIAM = GU - GL
* Input arguments for DLAEBZ:
* The relative tolerance. An interval (a,b] lies within
* "relative tolerance" if b-a < RELTOL*max(|a|,|b|),
RTOLI = RELTOL
* Set the absolute tolerance for interval convergence to zero to force
* interval convergence based on relative size of the interval.
* This is dangerous because intervals might not converge when RELTOL is
* small. But at least a very small number should be selected so that for
* strongly graded matrices, the code can get relatively accurate
* eigenvalues.
ATOLI = FUDGE*TWO*UFLOW + FUDGE*TWO*PIVMIN
IF( IRANGE.EQ.INDRNG ) THEN
* RANGE='I': Compute an interval containing eigenvalues
* IL through IU. The initial interval [GL,GU] from the global
* Gerschgorin bounds GL and GU is refined by DLAEBZ.
ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
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, E2, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
$ IWORK, W, IBLOCK, IINFO )
IF( IINFO .NE. 0 ) THEN
INFO = IINFO
RETURN
END IF
* On exit, output intervals may not be ordered by ascending negcount
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
* On exit, the interval [WL, WLU] contains a value with negcount NWL,
* and [WUL, WU] contains a value with negcount NWU.
IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
INFO = 4
RETURN
END IF
ELSEIF( IRANGE.EQ.VALRNG ) THEN
WL = VL
WU = VU
ELSEIF( IRANGE.EQ.ALLRNG ) THEN
WL = GL
WU = GU
ENDIF
* 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 JBLK = 1, NSPLIT
IOFF = IEND
IBEGIN = IOFF + 1
IEND = ISPLIT( JBLK )
IN = IEND - IOFF
*
IF( IN.EQ.1 ) THEN
* 1x1 block
IF( WL.GE.D( IBEGIN )-PIVMIN )
$ NWL = NWL + 1
IF( WU.GE.D( IBEGIN )-PIVMIN )
$ NWU = NWU + 1
IF( IRANGE.EQ.ALLRNG .OR.
$ ( WL.LT.D( IBEGIN )-PIVMIN
$ .AND. WU.GE. D( IBEGIN )-PIVMIN ) ) THEN
M = M + 1
W( M ) = D( IBEGIN )
WERR(M) = ZERO
* The gap for a single block doesn't matter for the later
* algorithm and is assigned an arbitrary large value
IBLOCK( M ) = JBLK
INDEXW( M ) = 1
END IF
* Disabled 2x2 case because of a failure on the following matrix
* RANGE = 'I', IL = IU = 4
* Original Tridiagonal, d = [
* -0.150102010615740E+00
* -0.849897989384260E+00
* -0.128208148052635E-15
* 0.128257718286320E-15
* ];
* e = [
* -0.357171383266986E+00
* -0.180411241501588E-15
* -0.175152352710251E-15
* ];
*
* ELSE IF( IN.EQ.2 ) THEN
** 2x2 block
* DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 )
* TMP1 = HALF*(D(IBEGIN)+D(IEND))
* L1 = TMP1 - DISC
* IF( WL.GE. L1-PIVMIN )
* $ NWL = NWL + 1
* IF( WU.GE. L1-PIVMIN )
* $ NWU = NWU + 1
* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE.
* $ L1-PIVMIN ) ) THEN
* M = M + 1
* W( M ) = L1
** The uncertainty of eigenvalues of a 2x2 matrix is very small
* WERR( M ) = EPS * ABS( W( M ) ) * TWO
* IBLOCK( M ) = JBLK
* INDEXW( M ) = 1
* ENDIF
* L2 = TMP1 + DISC
* IF( WL.GE. L2-PIVMIN )
* $ NWL = NWL + 1
* IF( WU.GE. L2-PIVMIN )
* $ NWU = NWU + 1
* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE.
* $ L2-PIVMIN ) ) THEN
* M = M + 1
* W( M ) = L2
** The uncertainty of eigenvalues of a 2x2 matrix is very small
* WERR( M ) = EPS * ABS( W( M ) ) * TWO
* IBLOCK( M ) = JBLK
* INDEXW( M ) = 2
* ENDIF
ELSE
* General Case - block of size IN >= 2
* Compute local Gerschgorin interval and use it as the initial
* interval for DLAEBZ
GU = D( IBEGIN )
GL = D( IBEGIN )
TMP1 = ZERO
DO 40 J = IBEGIN, IEND
GL = MIN( GL, GERS( 2*J - 1))
GU = MAX( GU, GERS(2*J) )
40 CONTINUE
* [JAN/28/2009]
* change SPDIAM by TNORM in lines 2 and 3 thereafter
* line 1: remove computation of SPDIAM (not useful anymore)
* SPDIAM = GU - GL
* GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN
* GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN
GL = GL - FUDGE*TNORM*EPS*IN - FUDGE*PIVMIN
GU = GU + FUDGE*TNORM*EPS*IN + FUDGE*PIVMIN
*
IF( IRANGE.GT.1 ) THEN
IF( GU.LT.WL ) THEN
* the local block contains none of the wanted eigenvalues
NWL = NWL + IN
NWU = NWU + IN
GO TO 70
END IF
* refine search interval if possible, only range (WL,WU] matters
GL = MAX( GL, WL )
GU = MIN( GU, WU )
IF( GL.GE.GU )
$ GO TO 70
END IF
* Find negcount of initial interval boundaries GL and GU
WORK( N+1 ) = GL
WORK( N+IN+1 ) = GU
CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
IF( IINFO .NE. 0 ) THEN
INFO = IINFO
RETURN
END IF
*
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 ), E2( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
IF( IINFO .NE. 0 ) THEN
INFO = IINFO
RETURN
END IF
*
* Copy eigenvalues into W and IBLOCK
* Use -JBLK for block number for unconverged eigenvalues.
* Loop over the number of output intervals from DLAEBZ
DO 60 J = 1, IOUT
* eigenvalue approximation is middle point of interval
TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
* semi length of error interval
TMP2 = HALF*ABS( WORK( J+N )-WORK( J+IN+N ) )
IF( J.GT.IOUT-IINFO ) THEN
* Flag non-convergence.
NCNVRG = .TRUE.
IB = -JBLK
ELSE
IB = JBLK
END IF
DO 50 JE = IWORK( J ) + 1 + IWOFF,
$ IWORK( J+IN ) + IWOFF
W( JE ) = TMP1
WERR( JE ) = TMP2
INDEXW( JE ) = JE - IWOFF
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.INDRNG ) THEN
IDISCL = IL - 1 - NWL
IDISCU = NWU - IU
*
IF( IDISCL.GT.0 ) THEN
IM = 0
DO 80 JE = 1, M
* Remove some of the smallest eigenvalues from the left so that
* at the end IDISCL =0. Move all eigenvalues up to the left.
IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
IDISCL = IDISCL - 1
ELSE
IM = IM + 1
W( IM ) = W( JE )
WERR( IM ) = WERR( JE )
INDEXW( IM ) = INDEXW( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
80 CONTINUE
M = IM
END IF
IF( IDISCU.GT.0 ) THEN
* Remove some of the largest eigenvalues from the right so that
* at the end IDISCU =0. Move all eigenvalues up to the left.
IM=M+1
DO 81 JE = M, 1, -1
IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
IDISCU = IDISCU - 1
ELSE
IM = IM - 1
W( IM ) = W( JE )
WERR( IM ) = WERR( JE )
INDEXW( IM ) = INDEXW( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
81 CONTINUE
JEE = 0
DO 82 JE = IM, M
JEE = JEE + 1
W( JEE ) = W( JE )
WERR( JEE ) = WERR( JE )
INDEXW( JEE ) = INDEXW( JE )
IBLOCK( JEE ) = IBLOCK( JE )
82 CONTINUE
M = M-IM+1
END IF
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
* Code to deal with effects of bad arithmetic. (If N(w) is
* monotone non-decreasing, this should never happen.)
* 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 marking the corresponding IBLOCK = 0
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 ).GE.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
110 CONTINUE
IBLOCK( IW ) = 0
120 CONTINUE
END IF
* Now erase all eigenvalues with IBLOCK set to zero
IM = 0
DO 130 JE = 1, M
IF( IBLOCK( JE ).NE.0 ) THEN
IM = IM + 1
W( IM ) = W( JE )
WERR( IM ) = WERR( JE )
INDEXW( IM ) = INDEXW( 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(( IRANGE.EQ.ALLRNG .AND. M.NE.N ).OR.
$ ( IRANGE.EQ.INDRNG .AND. M.NE.IU-IL+1 ) ) THEN
TOOFEW = .TRUE.
END IF
* If ORDER='B', do nothing the eigenvalues are already sorted by
* block.
* If ORDER='E', sort the eigenvalues from smallest to largest
IF( LSAME(ORDER,'E') .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
TMP2 = WERR( IE )
ITMP1 = IBLOCK( IE )
ITMP2 = INDEXW( IE )
W( IE ) = W( JE )
WERR( IE ) = WERR( JE )
IBLOCK( IE ) = IBLOCK( JE )
INDEXW( IE ) = INDEXW( JE )
W( JE ) = TMP1
WERR( JE ) = TMP2
IBLOCK( JE ) = ITMP1
INDEXW( JE ) = ITMP2
END IF
150 CONTINUE
END IF
*
INFO = 0
IF( NCNVRG )
$ INFO = INFO + 1
IF( TOOFEW )
$ INFO = INFO + 2
RETURN
*
* End of DLARRD
*
END
SUBROUTINE DLARRK( N, IW, GL, GU,
$ D, E2, PIVMIN, RELTOL, W, WERR, INFO)
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, IW, N
DOUBLE PRECISION PIVMIN, RELTOL, GL, GU, W, WERR
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E2( * )
* ..
*
* Purpose
* =======
*
* DLARRK computes one eigenvalue of a symmetric tridiagonal
* matrix T to suitable accuracy. This is an auxiliary code to be
* called from DSTEMR.
*
* To avoid overflow, the matrix must be scaled so that its
* largest element 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.
*
* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
* Matrix", Report CS41, Computer Science Dept., Stanford
* University, July 21, 1966.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the tridiagonal matrix T. N >= 0.
*
* IW (input) INTEGER
* The index of the eigenvalues to be returned.
*
* GL (input) DOUBLE PRECISION
* GU (input) DOUBLE PRECISION
* An upper and a lower bound on the eigenvalue.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the tridiagonal matrix T.
*
* E2 (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot allowed in the Sturm sequence for T.
*
* RELTOL (input) DOUBLE PRECISION
* The minimum relative width of an interval. When an interval
* is narrower 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.
*
* W (output) DOUBLE PRECISION
*
* WERR (output) DOUBLE PRECISION
* The error bound on the corresponding eigenvalue approximation
* in W.
*
* INFO (output) INTEGER
* = 0: Eigenvalue converged
* = -1: Eigenvalue did NOT converge
*
* Internal Parameters
* ===================
*
* FUDGE DOUBLE PRECISION, default = 2
* A "fudge factor" to widen the Gershgorin intervals.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION FUDGE, HALF, TWO, ZERO
PARAMETER ( HALF = 0.5D0, TWO = 2.0D0,
$ FUDGE = TWO, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IT, ITMAX, NEGCNT
DOUBLE PRECISION ATOLI, EPS, LEFT, MID, RIGHT, RTOLI, TMP1,
$ TMP2, TNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Get machine constants
EPS = DLAMCH( 'P' )
TNORM = MAX( ABS( GL ), ABS( GU ) )
RTOLI = RELTOL
ATOLI = FUDGE*TWO*PIVMIN
ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
INFO = -1
LEFT = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
RIGHT = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
IT = 0
10 CONTINUE
*
* Check if interval converged or maximum number of iterations reached
*
TMP1 = ABS( RIGHT - LEFT )
TMP2 = MAX( ABS(RIGHT), ABS(LEFT) )
IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) ) THEN
INFO = 0
GOTO 30
ENDIF
IF(IT.GT.ITMAX)
$ GOTO 30
*
* Count number of negative pivots for mid-point
*
IT = IT + 1
MID = HALF * (LEFT + RIGHT)
NEGCNT = 0
TMP1 = D( 1 ) - MID
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
IF( TMP1.LE.ZERO )
$ NEGCNT = NEGCNT + 1
*
DO 20 I = 2, N
TMP1 = D( I ) - E2( I-1 ) / TMP1 - MID
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
IF( TMP1.LE.ZERO )
$ NEGCNT = NEGCNT + 1
20 CONTINUE
IF(NEGCNT.GE.IW) THEN
RIGHT = MID
ELSE
LEFT = MID
ENDIF
GOTO 10
30 CONTINUE
*
* Converged or maximum number of iterations reached
*
W = HALF * (LEFT + RIGHT)
WERR = HALF * ABS( RIGHT - LEFT )
RETURN
*
* End of DLARRK
*
END
SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1,
$ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK,
$ PIVMIN, SPDIAM, TWIST, INFO )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST
DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPDIAM
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), LLD( * ), W( * ),
$ WERR( * ), WGAP( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* Given the relatively robust representation(RRR) L D L^T, DLARRB
* does "limited" bisection to refine the eigenvalues of L D L^T,
* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
* guesses for these eigenvalues are input in W, the corresponding estimate
* of the error in these guesses and their gaps are input in WERR
* and WGAP, respectively. During bisection, intervals
* [left, right] are maintained by storing their mid-points and
* semi-widths in the arrays W and WERR respectively.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The N diagonal elements of the diagonal matrix D.
*
* LLD (input) DOUBLE PRECISION array, dimension (N-1)
* The (N-1) elements L(i)*L(i)*D(i).
*
* IFIRST (input) INTEGER
* The index of the first eigenvalue to be computed.
*
* ILAST (input) INTEGER
* The index of the last eigenvalue to be computed.
*
* RTOL1 (input) DOUBLE PRECISION
* RTOL2 (input) DOUBLE PRECISION
* Tolerance for the convergence of the bisection intervals.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
* where GAP is the (estimated) distance to the nearest
* eigenvalue.
*
* OFFSET (input) INTEGER
* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET
* through ILAST-OFFSET elements of these arrays are to be used.
*
* W (input/output) DOUBLE PRECISION array, dimension (N)
* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
* estimates of the eigenvalues of L D L^T indexed IFIRST throug
* ILAST.
* On output, these estimates are refined.
*
* WGAP (input/output) DOUBLE PRECISION array, dimension (N-1)
* On input, the (estimated) gaps between consecutive
* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between
* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST
* then WGAP(IFIRST-OFFSET) must be set to ZERO.
* On output, these gaps are refined.
*
* WERR (input/output) DOUBLE PRECISION array, dimension (N)
* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
* the errors in the estimates of the corresponding elements in W.
* On output, these errors are refined.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
* Workspace.
*
* IWORK (workspace) INTEGER array, dimension (2*N)
* Workspace.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence.
*
* SPDIAM (input) DOUBLE PRECISION
* The spectral diameter of the matrix.
*
* TWIST (input) INTEGER
* The twist index for the twisted factorization that is used
* for the negcount.
* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T
* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T
* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)
*
* INFO (output) INTEGER
* Error flag.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, TWO, HALF
PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0,
$ HALF = 0.5D0 )
INTEGER MAXITR
* ..
* .. Local Scalars ..
INTEGER I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT,
$ OLNINT, PREV, R
DOUBLE PRECISION BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH,
$ RGAP, RIGHT, TMP, WIDTH
* ..
* .. External Functions ..
INTEGER DLANEG
EXTERNAL DLANEG
*
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
*
MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
MNWDTH = TWO * PIVMIN
*
R = TWIST
IF((R.LT.1).OR.(R.GT.N)) R = N
*
* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
* for an unconverged interval is set to the index of the next unconverged
* interval, and is -1 or 0 for a converged interval. Thus a linked
* list of unconverged intervals is set up.
*
I1 = IFIRST
* The number of unconverged intervals
NINT = 0
* The last unconverged interval found
PREV = 0
RGAP = WGAP( I1-OFFSET )
DO 75 I = I1, ILAST
K = 2*I
II = I - OFFSET
LEFT = W( II ) - WERR( II )
RIGHT = W( II ) + WERR( II )
LGAP = RGAP
RGAP = WGAP( II )
GAP = MIN( LGAP, RGAP )
* Make sure that [LEFT,RIGHT] contains the desired eigenvalue
* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT
*
* Do while( NEGCNT(LEFT).GT.I-1 )
*
BACK = WERR( II )
20 CONTINUE
NEGCNT = DLANEG( N, D, LLD, LEFT, PIVMIN, R )
IF( NEGCNT.GT.I-1 ) THEN
LEFT = LEFT - BACK
BACK = TWO*BACK
GO TO 20
END IF
*
* Do while( NEGCNT(RIGHT).LT.I )
* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT
*
BACK = WERR( II )
50 CONTINUE
NEGCNT = DLANEG( N, D, LLD, RIGHT, PIVMIN, R )
IF( NEGCNT.LT.I ) THEN
RIGHT = RIGHT + BACK
BACK = TWO*BACK
GO TO 50
END IF
WIDTH = HALF*ABS( LEFT - RIGHT )
TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
IF( WIDTH.LE.CVRGD .OR. WIDTH.LE.MNWDTH ) THEN
* This interval has already converged and does not need refinement.
* (Note that the gaps might change through refining the
* eigenvalues, however, they can only get bigger.)
* Remove it from the list.
IWORK( K-1 ) = -1
* Make sure that I1 always points to the first unconverged interval
IF((I.EQ.I1).AND.(I.LT.ILAST)) I1 = I + 1
IF((PREV.GE.I1).AND.(I.LE.ILAST)) IWORK( 2*PREV-1 ) = I + 1
ELSE
* unconverged interval found
PREV = I
NINT = NINT + 1
IWORK( K-1 ) = I + 1
IWORK( K ) = NEGCNT
END IF
WORK( K-1 ) = LEFT
WORK( K ) = RIGHT
75 CONTINUE
*
* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
* and while (ITER.LT.MAXITR)
*
ITER = 0
80 CONTINUE
PREV = I1 - 1
I = I1
OLNINT = NINT
DO 100 IP = 1, OLNINT
K = 2*I
II = I - OFFSET
RGAP = WGAP( II )
LGAP = RGAP
IF(II.GT.1) LGAP = WGAP( II-1 )
GAP = MIN( LGAP, RGAP )
NEXT = IWORK( K-1 )
LEFT = WORK( K-1 )
RIGHT = WORK( K )
MID = HALF*( LEFT + RIGHT )
* semiwidth of interval
WIDTH = RIGHT - MID
TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
IF( ( WIDTH.LE.CVRGD ) .OR. ( WIDTH.LE.MNWDTH ).OR.
$ ( ITER.EQ.MAXITR ) )THEN
* reduce number of unconverged intervals
NINT = NINT - 1
* Mark interval as converged.
IWORK( K-1 ) = 0
IF( I1.EQ.I ) THEN
I1 = NEXT
ELSE
* Prev holds the last unconverged interval previously examined
IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
END IF
I = NEXT
GO TO 100
END IF
PREV = I
*
* Perform one bisection step
*
NEGCNT = DLANEG( N, D, LLD, MID, PIVMIN, R )
IF( NEGCNT.LE.I-1 ) THEN
WORK( K-1 ) = MID
ELSE
WORK( K ) = MID
END IF
I = NEXT
100 CONTINUE
ITER = ITER + 1
* do another loop if there are still unconverged intervals
* However, in the last iteration, all intervals are accepted
* since this is the best we can do.
IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
*
*
* At this point, all the intervals have converged
DO 110 I = IFIRST, ILAST
K = 2*I
II = I - OFFSET
* All intervals marked by '0' have been refined.
IF( IWORK( K-1 ).EQ.0 ) THEN
W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
WERR( II ) = WORK( K ) - W( II )
END IF
110 CONTINUE
*
DO 111 I = IFIRST+1, ILAST
K = 2*I
II = I - OFFSET
WGAP( II-1 ) = MAX( ZERO,
$ W(II) - WERR (II) - W( II-1 ) - WERR( II-1 ))
111 CONTINUE
RETURN
*
* End of DLARRB
*
END
SUBROUTINE DLASQ2( N, Z, INFO )
*
* -- LAPACK routine (version 3.2) --
*
* -- Contributed by Osni Marques of the Lawrence Berkeley National --
* -- Laboratory and Beresford Parlett of the Univ. of California at --
* -- Berkeley --
* -- November 2008 --
*
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLASQ2 computes all the eigenvalues of the symmetric positive
* definite tridiagonal matrix associated with the qd array Z to high
* relative accuracy are computed to high relative accuracy, in the
* absence of denormalization, underflow and overflow.
*
* To see the relation of Z to the tridiagonal matrix, let L be a
* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
* let U be an upper bidiagonal matrix with 1's above and diagonal
* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
* symmetric tridiagonal to which it is similar.
*
* Note : DLASQ2 defines a logical variable, IEEE, which is true
* on machines which follow ieee-754 floating-point standard in their
* handling of infinities and NaNs, and false otherwise. This variable
* is passed to DLASQ3.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of rows and columns in the matrix. N >= 0.
*
* Z (input/output) DOUBLE PRECISION array, dimension ( 4*N )
* On entry Z holds the qd array. On exit, entries 1 to N hold
* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
* shifts that failed.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if the i-th argument is a scalar and had an illegal
* value, then INFO = -i, if the i-th argument is an
* array and the j-entry had an illegal value, then
* INFO = -(i*100+j)
* > 0: the algorithm failed
* = 1, a split was marked by a positive value in E
* = 2, current block of Z not diagonalized after 30*N
* iterations (in inner while loop)
* = 3, termination criterion of outer while loop not met
* (program created more than N unreduced blocks)
*
* Further Details
* ===============
* Local Variables: I0:N0 defines a current unreduced segment of Z.
* The shifts are accumulated in SIGMA. Iteration count is in ITER.
* Ping-pong is controlled by PP (alternates between 0 and 1).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CBIAS
PARAMETER ( CBIAS = 1.50D0 )
DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, HUNDRD
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
$ TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
LOGICAL IEEE
INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K,
$ KMIN, N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE
DOUBLE PRECISION D, DEE, DEEMIN, DESIG, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, E, EMAX, EMIN, EPS, G, OLDEMN, QMAX,
$ QMIN, S, SAFMIN, SIGMA, T, TAU, TEMP, TOL,
$ TOL2, TRACE, ZMAX
* ..
* .. External Subroutines ..
EXTERNAL DLASQ3, DLASRT, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH, ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments.
* (in case DLASQ2 is not called by DLASQ1)
*
INFO = 0
EPS = DLAMCH( 'Precision' )
SAFMIN = DLAMCH( 'Safe minimum' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
*
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DLASQ2', 1 )
RETURN
ELSE IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
*
* 1-by-1 case.
*
IF( Z( 1 ).LT.ZERO ) THEN
INFO = -201
CALL XERBLA( 'DLASQ2', 2 )
END IF
RETURN
ELSE IF( N.EQ.2 ) THEN
*
* 2-by-2 case.
*
IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN
INFO = -2
CALL XERBLA( 'DLASQ2', 2 )
RETURN
ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN
D = Z( 3 )
Z( 3 ) = Z( 1 )
Z( 1 ) = D
END IF
Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 )
IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN
T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) )
S = Z( 3 )*( Z( 2 ) / T )
IF( S.LE.T ) THEN
S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
T = Z( 1 ) + ( S+Z( 2 ) )
Z( 3 ) = Z( 3 )*( Z( 1 ) / T )
Z( 1 ) = T
END IF
Z( 2 ) = Z( 3 )
Z( 6 ) = Z( 2 ) + Z( 1 )
RETURN
END IF
*
* Check for negative data and compute sums of q's and e's.
*
Z( 2*N ) = ZERO
EMIN = Z( 2 )
QMAX = ZERO
ZMAX = ZERO
D = ZERO
E = ZERO
*
DO 10 K = 1, 2*( N-1 ), 2
IF( Z( K ).LT.ZERO ) THEN
INFO = -( 200+K )
CALL XERBLA( 'DLASQ2', 2 )
RETURN
ELSE IF( Z( K+1 ).LT.ZERO ) THEN
INFO = -( 200+K+1 )
CALL XERBLA( 'DLASQ2', 2 )
RETURN
END IF
D = D + Z( K )
E = E + Z( K+1 )
QMAX = MAX( QMAX, Z( K ) )
EMIN = MIN( EMIN, Z( K+1 ) )
ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) )
10 CONTINUE
IF( Z( 2*N-1 ).LT.ZERO ) THEN
INFO = -( 200+2*N-1 )
CALL XERBLA( 'DLASQ2', 2 )
RETURN
END IF
D = D + Z( 2*N-1 )
QMAX = MAX( QMAX, Z( 2*N-1 ) )
ZMAX = MAX( QMAX, ZMAX )
*
* Check for diagonality.
*
IF( E.EQ.ZERO ) THEN
DO 20 K = 2, N
Z( K ) = Z( 2*K-1 )
20 CONTINUE
CALL DLASRT( 'D', N, Z, IINFO )
Z( 2*N-1 ) = D
RETURN
END IF
*
TRACE = D + E
*
* Check for zero data.
*
IF( TRACE.EQ.ZERO ) THEN
Z( 2*N-1 ) = ZERO
RETURN
END IF
*
* Check whether the machine is IEEE conformable.
*
IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND.
$ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1
*
* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
*
DO 30 K = 2*N, 2, -2
Z( 2*K ) = ZERO
Z( 2*K-1 ) = Z( K )
Z( 2*K-2 ) = ZERO
Z( 2*K-3 ) = Z( K-1 )
30 CONTINUE
*
I0 = 1
N0 = N
*
* Reverse the qd-array, if warranted.
*
IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( I4-3 )
Z( I4-3 ) = Z( IPN4-I4-3 )
Z( IPN4-I4-3 ) = TEMP
TEMP = Z( I4-1 )
Z( I4-1 ) = Z( IPN4-I4-5 )
Z( IPN4-I4-5 ) = TEMP
40 CONTINUE
END IF
*
* Initial split checking via dqd and Li's test.
*
PP = 0
*
DO 80 K = 1, 2
*
D = Z( 4*N0+PP-3 )
DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4
IF( Z( I4-1 ).LE.TOL2*D ) THEN
Z( I4-1 ) = -ZERO
D = Z( I4-3 )
ELSE
D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) )
END IF
50 CONTINUE
*
* dqd maps Z to ZZ plus Li's test.
*
EMIN = Z( 4*I0+PP+1 )
D = Z( 4*I0+PP-3 )
DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4
Z( I4-2*PP-2 ) = D + Z( I4-1 )
IF( Z( I4-1 ).LE.TOL2*D ) THEN
Z( I4-1 ) = -ZERO
Z( I4-2*PP-2 ) = D
Z( I4-2*PP ) = ZERO
D = Z( I4+1 )
ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND.
$ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN
TEMP = Z( I4+1 ) / Z( I4-2*PP-2 )
Z( I4-2*PP ) = Z( I4-1 )*TEMP
D = D*TEMP
ELSE
Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) )
D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) )
END IF
EMIN = MIN( EMIN, Z( I4-2*PP ) )
60 CONTINUE
Z( 4*N0-PP-2 ) = D
*
* Now find qmax.
*
QMAX = Z( 4*I0-PP-2 )
DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4
QMAX = MAX( QMAX, Z( I4 ) )
70 CONTINUE
*
* Prepare for the next iteration on K.
*
PP = 1 - PP
80 CONTINUE
*
* Initialise variables to pass to DLASQ3.
*
TTYPE = 0
DMIN1 = ZERO
DMIN2 = ZERO
DN = ZERO
DN1 = ZERO
DN2 = ZERO
G = ZERO
TAU = ZERO
*
ITER = 2
NFAIL = 0
NDIV = 2*( N0-I0 )
*
DO 160 IWHILA = 1, N + 1
IF( N0.LT.1 )
$ GO TO 170
*
* While array unfinished do
*
* E(N0) holds the value of SIGMA when submatrix in I0:N0
* splits from the rest of the array, but is negated.
*
DESIG = ZERO
IF( N0.EQ.N ) THEN
SIGMA = ZERO
ELSE
SIGMA = -Z( 4*N0-1 )
END IF
IF( SIGMA.LT.ZERO ) THEN
INFO = 1
RETURN
END IF
*
* Find last unreduced submatrix's top index I0, find QMAX and
* EMIN. Find Gershgorin-type bound if Q's much greater than E's.
*
EMAX = ZERO
IF( N0.GT.I0 ) THEN
EMIN = ABS( Z( 4*N0-5 ) )
ELSE
EMIN = ZERO
END IF
QMIN = Z( 4*N0-3 )
QMAX = QMIN
DO 90 I4 = 4*N0, 8, -4
IF( Z( I4-5 ).LE.ZERO )
$ GO TO 100
IF( QMIN.GE.FOUR*EMAX ) THEN
QMIN = MIN( QMIN, Z( I4-3 ) )
EMAX = MAX( EMAX, Z( I4-5 ) )
END IF
QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) )
EMIN = MIN( EMIN, Z( I4-5 ) )
90 CONTINUE
I4 = 4
*
100 CONTINUE
I0 = I4 / 4
PP = 0
*
IF( N0-I0.GT.1 ) THEN
DEE = Z( 4*I0-3 )
DEEMIN = DEE
KMIN = I0
DO 110 I4 = 4*I0+1, 4*N0-3, 4
DEE = Z( I4 )*( DEE /( DEE+Z( I4-2 ) ) )
IF( DEE.LE.DEEMIN ) THEN
DEEMIN = DEE
KMIN = ( I4+3 )/4
END IF
110 CONTINUE
IF( (KMIN-I0)*2.LT.N0-KMIN .AND.
$ DEEMIN.LE.HALF*Z(4*N0-3) ) THEN
IPN4 = 4*( I0+N0 )
PP = 2
DO 120 I4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( I4-3 )
Z( I4-3 ) = Z( IPN4-I4-3 )
Z( IPN4-I4-3 ) = TEMP
TEMP = Z( I4-2 )
Z( I4-2 ) = Z( IPN4-I4-2 )
Z( IPN4-I4-2 ) = TEMP
TEMP = Z( I4-1 )
Z( I4-1 ) = Z( IPN4-I4-5 )
Z( IPN4-I4-5 ) = TEMP
TEMP = Z( I4 )
Z( I4 ) = Z( IPN4-I4-4 )
Z( IPN4-I4-4 ) = TEMP
120 CONTINUE
END IF
END IF
*
* Put -(initial shift) into DMIN.
*
DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) )
*
* Now I0:N0 is unreduced.
* PP = 0 for ping, PP = 1 for pong.
* PP = 2 indicates that flipping was applied to the Z array and
* and that the tests for deflation upon entry in DLASQ3
* should not be performed.
*
NBIG = 30*( N0-I0+1 )
DO 140 IWHILB = 1, NBIG
IF( I0.GT.N0 )
$ GO TO 150
*
* While submatrix unfinished take a good dqds step.
*
CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
$ DN2, G, TAU )
*
PP = 1 - PP
*
* When EMIN is very small check for splits.
*
IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN
IF( Z( 4*N0 ).LE.TOL2*QMAX .OR.
$ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN
SPLT = I0 - 1
QMAX = Z( 4*I0-3 )
EMIN = Z( 4*I0-1 )
OLDEMN = Z( 4*I0 )
DO 130 I4 = 4*I0, 4*( N0-3 ), 4
IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR.
$ Z( I4-1 ).LE.TOL2*SIGMA ) THEN
Z( I4-1 ) = -SIGMA
SPLT = I4 / 4
QMAX = ZERO
EMIN = Z( I4+3 )
OLDEMN = Z( I4+4 )
ELSE
QMAX = MAX( QMAX, Z( I4+1 ) )
EMIN = MIN( EMIN, Z( I4-1 ) )
OLDEMN = MIN( OLDEMN, Z( I4 ) )
END IF
130 CONTINUE
Z( 4*N0-1 ) = EMIN
Z( 4*N0 ) = OLDEMN
I0 = SPLT + 1
END IF
END IF
*
140 CONTINUE
*
INFO = 2
RETURN
*
* end IWHILB
*
150 CONTINUE
*
160 CONTINUE
*
INFO = 3
RETURN
*
* end IWHILA
*
170 CONTINUE
*
* Move q's to the front.
*
DO 180 K = 2, N
Z( K ) = Z( 4*K-3 )
180 CONTINUE
*
* Sort and compute sum of eigenvalues.
*
CALL DLASRT( 'D', N, Z, IINFO )
*
E = ZERO
DO 190 K = N, 1, -1
E = E + Z( K )
190 CONTINUE
*
* Store trace, sum(eigenvalues) and information on performance.
*
Z( 2*N+1 ) = TRACE
Z( 2*N+2 ) = E
Z( 2*N+3 ) = DBLE( ITER )
Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 )
Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER )
RETURN
*
* End of DLASQ2
*
END
SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND,
$ W, WGAP, WERR,
$ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
$ DPLUS, LPLUS, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
**
* .. Scalar Arguments ..
INTEGER CLSTRT, CLEND, INFO, N
DOUBLE PRECISION CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DPLUS( * ), L( * ), LD( * ),
$ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* Given the initial representation L D L^T and its cluster of close
* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
* W( CLEND ), DLARRF finds a new relatively robust representation
* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix (subblock, if the matrix splitted).
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The N diagonal elements of the diagonal matrix D.
*
* L (input) DOUBLE PRECISION array, dimension (N-1)
* The (N-1) subdiagonal elements of the unit bidiagonal
* matrix L.
*
* LD (input) DOUBLE PRECISION array, dimension (N-1)
* The (N-1) elements L(i)*D(i).
*
* CLSTRT (input) INTEGER
* The index of the first eigenvalue in the cluster.
*
* CLEND (input) INTEGER
* The index of the last eigenvalue in the cluster.
*
* W (input) DOUBLE PRECISION array, dimension
* dimension is >= (CLEND-CLSTRT+1)
* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
* W( CLSTRT ) through W( CLEND ) form the cluster of relatively
* close eigenalues.
*
* WGAP (input/output) DOUBLE PRECISION array, dimension
* dimension is >= (CLEND-CLSTRT+1)
* The separation from the right neighbor eigenvalue in W.
*
* WERR (input) DOUBLE PRECISION array, dimension
* dimension is >= (CLEND-CLSTRT+1)
* WERR contain the semiwidth of the uncertainty
* interval of the corresponding eigenvalue APPROXIMATION in W
*
* SPDIAM (input) DOUBLE PRECISION
* estimate of the spectral diameter obtained from the
* Gerschgorin intervals
*
* CLGAPL (input) DOUBLE PRECISION
*
* CLGAPR (input) DOUBLE PRECISION
* absolute gap on each end of the cluster.
* Set by the calling routine to protect against shifts too close
* to eigenvalues outside the cluster.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot allowed in the Sturm sequence.
*
* SIGMA (output) DOUBLE PRECISION
* The shift used to form L(+) D(+) L(+)^T.
*
* DPLUS (output) DOUBLE PRECISION array, dimension (N)
* The N diagonal elements of the diagonal matrix D(+).
*
* LPLUS (output) DOUBLE PRECISION array, dimension (N-1)
* The first (N-1) elements of LPLUS contain the subdiagonal
* elements of the unit bidiagonal matrix L(+).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
* Workspace.
*
* INFO (output) INTEGER
* Signals processing OK (=0) or failure (=1)
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO,
$ ZERO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ FOUR = 4.0D0, QUART = 0.25D0,
$ MAXGROWTH1 = 8.D0,
$ MAXGROWTH2 = 8.D0 )
* ..
* .. Local Scalars ..
LOGICAL DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
INTEGER I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT
PARAMETER ( KTRYMAX = 1, SLEFT = 1, SRIGHT = 2 )
DOUBLE PRECISION AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
$ FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA,
$ MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX,
$ RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2
* ..
* .. External Functions ..
LOGICAL DISNAN
DOUBLE PRECISION DLAMCH
EXTERNAL DISNAN, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
INFO = 0
FACT = DBLE(2**KTRYMAX)
EPS = DLAMCH( 'Precision' )
SHIFT = 0
FORCER = .FALSE.
* Note that we cannot guarantee that for any of the shifts tried,
* the factorization has a small or even moderate element growth.
* There could be Ritz values at both ends of the cluster and despite
* backing off, there are examples where all factorizations tried
* (in IEEE mode, allowing zero pivots & infinities) have INFINITE
* element growth.
* For this reason, we should use PIVMIN in this subroutine so that at
* least the L D L^T factorization exists. It can be checked afterwards
* whether the element growth caused bad residuals/orthogonality.
* Decide whether the code should accept the best among all
* representations despite large element growth or signal INFO=1
NOFAIL = .TRUE.
*
* Compute the average gap length of the cluster
CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT)
AVGAP = CLWDTH / DBLE(CLEND-CLSTRT)
MINGAP = MIN(CLGAPL, CLGAPR)
* Initial values for shifts to both ends of cluster
LSIGMA = MIN(W( CLSTRT ),W( CLEND )) - WERR( CLSTRT )
RSIGMA = MAX(W( CLSTRT ),W( CLEND )) + WERR( CLEND )
* Use a small fudge to make sure that we really shift to the outside
LSIGMA = LSIGMA - ABS(LSIGMA)* FOUR * EPS
RSIGMA = RSIGMA + ABS(RSIGMA)* FOUR * EPS
* Compute upper bounds for how much to back off the initial shifts
LDMAX = QUART * MINGAP + TWO * PIVMIN
RDMAX = QUART * MINGAP + TWO * PIVMIN
LDELTA = MAX(AVGAP,WGAP( CLSTRT ))/FACT
RDELTA = MAX(AVGAP,WGAP( CLEND-1 ))/FACT
*
* Initialize the record of the best representation found
*
S = DLAMCH( 'S' )
SMLGROWTH = ONE / S
FAIL = DBLE(N-1)*MINGAP/(SPDIAM*EPS)
FAIL2 = DBLE(N-1)*MINGAP/(SPDIAM*SQRT(EPS))
BESTSHIFT = LSIGMA
*
* while (KTRY <= KTRYMAX)
KTRY = 0
GROWTHBOUND = MAXGROWTH1*SPDIAM
5 CONTINUE
SAWNAN1 = .FALSE.
SAWNAN2 = .FALSE.
* Ensure that we do not back off too much of the initial shifts
LDELTA = MIN(LDMAX,LDELTA)
RDELTA = MIN(RDMAX,RDELTA)
* Compute the element growth when shifting to both ends of the cluster
* accept the shift if there is no element growth at one of the two ends
* Left end
S = -LSIGMA
DPLUS( 1 ) = D( 1 ) + S
IF(ABS(DPLUS(1)).LT.PIVMIN) THEN
DPLUS(1) = -PIVMIN
* Need to set SAWNAN1 because refined RRR test should not be used
* in this case
SAWNAN1 = .TRUE.
ENDIF
MAX1 = ABS( DPLUS( 1 ) )
DO 6 I = 1, N - 1
LPLUS( I ) = LD( I ) / DPLUS( I )
S = S*LPLUS( I )*L( I ) - LSIGMA
DPLUS( I+1 ) = D( I+1 ) + S
IF(ABS(DPLUS(I+1)).LT.PIVMIN) THEN
DPLUS(I+1) = -PIVMIN
* Need to set SAWNAN1 because refined RRR test should not be used
* in this case
SAWNAN1 = .TRUE.
ENDIF
MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
6 CONTINUE
SAWNAN1 = SAWNAN1 .OR. DISNAN( MAX1 )
IF( FORCER .OR.
$ (MAX1.LE.GROWTHBOUND .AND. .NOT.SAWNAN1 ) ) THEN
SIGMA = LSIGMA
SHIFT = SLEFT
GOTO 100
ENDIF
* Right end
S = -RSIGMA
WORK( 1 ) = D( 1 ) + S
IF(ABS(WORK(1)).LT.PIVMIN) THEN
WORK(1) = -PIVMIN
* Need to set SAWNAN2 because refined RRR test should not be used
* in this case
SAWNAN2 = .TRUE.
ENDIF
MAX2 = ABS( WORK( 1 ) )
DO 7 I = 1, N - 1
WORK( N+I ) = LD( I ) / WORK( I )
S = S*WORK( N+I )*L( I ) - RSIGMA
WORK( I+1 ) = D( I+1 ) + S
IF(ABS(WORK(I+1)).LT.PIVMIN) THEN
WORK(I+1) = -PIVMIN
* Need to set SAWNAN2 because refined RRR test should not be used
* in this case
SAWNAN2 = .TRUE.
ENDIF
MAX2 = MAX( MAX2,ABS(WORK(I+1)) )
7 CONTINUE
SAWNAN2 = SAWNAN2 .OR. DISNAN( MAX2 )
IF( FORCER .OR.
$ (MAX2.LE.GROWTHBOUND .AND. .NOT.SAWNAN2 ) ) THEN
SIGMA = RSIGMA
SHIFT = SRIGHT
GOTO 100
ENDIF
* If we are at this point, both shifts led to too much element growth
* Record the better of the two shifts (provided it didn't lead to NaN)
IF(SAWNAN1.AND.SAWNAN2) THEN
* both MAX1 and MAX2 are NaN
GOTO 50
ELSE
IF( .NOT.SAWNAN1 ) THEN
INDX = 1
IF(MAX1.LE.SMLGROWTH) THEN
SMLGROWTH = MAX1
BESTSHIFT = LSIGMA
ENDIF
ENDIF
IF( .NOT.SAWNAN2 ) THEN
IF(SAWNAN1 .OR. MAX2.LE.MAX1) INDX = 2
IF(MAX2.LE.SMLGROWTH) THEN
SMLGROWTH = MAX2
BESTSHIFT = RSIGMA
ENDIF
ENDIF
ENDIF
* If we are here, both the left and the right shift led to
* element growth. If the element growth is moderate, then
* we may still accept the representation, if it passes a
* refined test for RRR. This test supposes that no NaN occurred.
* Moreover, we use the refined RRR test only for isolated clusters.
IF((CLWDTH.LT.MINGAP/DBLE(128)) .AND.
$ (MIN(MAX1,MAX2).LT.FAIL2)
$ .AND.(.NOT.SAWNAN1).AND.(.NOT.SAWNAN2)) THEN
DORRR1 = .TRUE.
ELSE
DORRR1 = .FALSE.
ENDIF
TRYRRR1 = .TRUE.
IF( TRYRRR1 .AND. DORRR1 ) THEN
IF(INDX.EQ.1) THEN
TMP = ABS( DPLUS( N ) )
ZNM2 = ONE
PROD = ONE
OLDP = ONE
DO 15 I = N-1, 1, -1
IF( PROD .LE. EPS ) THEN
PROD =
$ ((DPLUS(I+1)*WORK(N+I+1))/(DPLUS(I)*WORK(N+I)))*OLDP
ELSE
PROD = PROD*ABS(WORK(N+I))
END IF
OLDP = PROD
ZNM2 = ZNM2 + PROD**2
TMP = MAX( TMP, ABS( DPLUS( I ) * PROD ))
15 CONTINUE
RRR1 = TMP/( SPDIAM * SQRT( ZNM2 ) )
IF (RRR1.LE.MAXGROWTH2) THEN
SIGMA = LSIGMA
SHIFT = SLEFT
GOTO 100
ENDIF
ELSE IF(INDX.EQ.2) THEN
TMP = ABS( WORK( N ) )
ZNM2 = ONE
PROD = ONE
OLDP = ONE
DO 16 I = N-1, 1, -1
IF( PROD .LE. EPS ) THEN
PROD = ((WORK(I+1)*LPLUS(I+1))/(WORK(I)*LPLUS(I)))*OLDP
ELSE
PROD = PROD*ABS(LPLUS(I))
END IF
OLDP = PROD
ZNM2 = ZNM2 + PROD**2
TMP = MAX( TMP, ABS( WORK( I ) * PROD ))
16 CONTINUE
RRR2 = TMP/( SPDIAM * SQRT( ZNM2 ) )
IF (RRR2.LE.MAXGROWTH2) THEN
SIGMA = RSIGMA
SHIFT = SRIGHT
GOTO 100
ENDIF
END IF
ENDIF
50 CONTINUE
IF (KTRY.LT.KTRYMAX) THEN
* If we are here, both shifts failed also the RRR test.
* Back off to the outside
LSIGMA = MAX( LSIGMA - LDELTA,
$ LSIGMA - LDMAX)
RSIGMA = MIN( RSIGMA + RDELTA,
$ RSIGMA + RDMAX )
LDELTA = TWO * LDELTA
RDELTA = TWO * RDELTA
KTRY = KTRY + 1
GOTO 5
ELSE
* None of the representations investigated satisfied our
* criteria. Take the best one we found.
IF((SMLGROWTH.LT.FAIL).OR.NOFAIL) THEN
LSIGMA = BESTSHIFT
RSIGMA = BESTSHIFT
FORCER = .TRUE.
GOTO 5
ELSE
INFO = 1
RETURN
ENDIF
END IF
100 CONTINUE
IF (SHIFT.EQ.SLEFT) THEN
ELSEIF (SHIFT.EQ.SRIGHT) THEN
* store new L and D back into DPLUS, LPLUS
CALL DCOPY( N, WORK, 1, DPLUS, 1 )
CALL DCOPY( N-1, WORK(N+1), 1, LPLUS, 1 )
ENDIF
RETURN
*
* End of DLARRF
*
END
SUBROUTINE ZLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD,
$ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
$ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
LOGICAL WANTNC
INTEGER B1, BN, N, NEGCNT, R
DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
$ RQCORR, ZTZ
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * )
DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ),
$ WORK( * )
COMPLEX*16 Z( * )
* ..
*
* Purpose
* =======
*
* ZLAR1V computes the (scaled) r-th column of the inverse of
* the sumbmatrix in rows B1 through BN of the tridiagonal matrix
* L D L^T - sigma I. When sigma is close to an eigenvalue, the
* computed vector is an accurate eigenvector. Usually, r corresponds
* to the index where the eigenvector is largest in magnitude.
* The following steps accomplish this computation :
* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,
* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
* (c) Computation of the diagonal elements of the inverse of
* L D L^T - sigma I by combining the above transforms, and choosing
* r as the index where the diagonal of the inverse is (one of the)
* largest in magnitude.
* (d) Computation of the (scaled) r-th column of the inverse using the
* twisted factorization obtained by combining the top part of the
* the stationary and the bottom part of the progressive transform.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix L D L^T.
*
* B1 (input) INTEGER
* First index of the submatrix of L D L^T.
*
* BN (input) INTEGER
* Last index of the submatrix of L D L^T.
*
* LAMBDA (input) DOUBLE PRECISION
* The shift. In order to compute an accurate eigenvector,
* LAMBDA should be a good approximation to an eigenvalue
* of L D L^T.
*
* L (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal matrix
* L, in elements 1 to N-1.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the diagonal matrix D.
*
* LD (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 elements L(i)*D(i).
*
* LLD (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 elements L(i)*L(i)*D(i).
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence.
*
* GAPTOL (input) DOUBLE PRECISION
* Tolerance that indicates when eigenvector entries are negligible
* w.r.t. their contribution to the residual.
*
* Z (input/output) COMPLEX*16 array, dimension (N)
* On input, all entries of Z must be set to 0.
* On output, Z contains the (scaled) r-th column of the
* inverse. The scaling is such that Z(R) equals 1.
*
* WANTNC (input) LOGICAL
* Specifies whether NEGCNT has to be computed.
*
* NEGCNT (output) INTEGER
* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise.
*
* ZTZ (output) DOUBLE PRECISION
* The square of the 2-norm of Z.
*
* MINGMA (output) DOUBLE PRECISION
* The reciprocal of the largest (in magnitude) diagonal
* element of the inverse of L D L^T - sigma I.
*
* R (input/output) INTEGER
* The twist index for the twisted factorization used to
* compute Z.
* On input, 0 <= R <= N. If R is input as 0, R is set to
* the index where (L D L^T - sigma I)^{-1} is largest
* in magnitude. If 1 <= R <= N, R is unchanged.
* On output, R contains the twist index used to compute Z.
* Ideally, R designates the position of the maximum entry in the
* eigenvector.
*
* ISUPPZ (output) INTEGER array, dimension (2)
* The support of the vector in Z, i.e., the vector Z is
* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
*
* NRMINV (output) DOUBLE PRECISION
* NRMINV = 1/SQRT( ZTZ )
*
* RESID (output) DOUBLE PRECISION
* The residual of the FP vector.
* RESID = ABS( MINGMA )/SQRT( ZTZ )
*
* RQCORR (output) DOUBLE PRECISION
* The Rayleigh Quotient correction to LAMBDA.
* RQCORR = MINGMA*TMP
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) )
* ..
* .. Local Scalars ..
LOGICAL SAWNAN1, SAWNAN2
INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
$ R2
DOUBLE PRECISION DMINUS, DPLUS, EPS, S, TMP
* ..
* .. External Functions ..
LOGICAL DISNAN
DOUBLE PRECISION DLAMCH
EXTERNAL DISNAN, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Precision' )
IF( R.EQ.0 ) THEN
R1 = B1
R2 = BN
ELSE
R1 = R
R2 = R
END IF
* Storage for LPLUS
INDLPL = 0
* Storage for UMINUS
INDUMN = N
INDS = 2*N + 1
INDP = 3*N + 1
IF( B1.EQ.1 ) THEN
WORK( INDS ) = ZERO
ELSE
WORK( INDS+B1-1 ) = LLD( B1-1 )
END IF
*
* Compute the stationary transform (using the differential form)
* until the index R2.
*
SAWNAN1 = .FALSE.
NEG1 = 0
S = WORK( INDS+B1-1 ) - LAMBDA
DO 50 I = B1, R1 - 1
DPLUS = D( I ) + S
WORK( INDLPL+I ) = LD( I ) / DPLUS
IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
S = WORK( INDS+I ) - LAMBDA
50 CONTINUE
SAWNAN1 = DISNAN( S )
IF( SAWNAN1 ) GOTO 60
DO 51 I = R1, R2 - 1
DPLUS = D( I ) + S
WORK( INDLPL+I ) = LD( I ) / DPLUS
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
S = WORK( INDS+I ) - LAMBDA
51 CONTINUE
SAWNAN1 = DISNAN( S )
*
60 CONTINUE
IF( SAWNAN1 ) THEN
* Runs a slower version of the above loop if a NaN is detected
NEG1 = 0
S = WORK( INDS+B1-1 ) - LAMBDA
DO 70 I = B1, R1 - 1
DPLUS = D( I ) + S
IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
WORK( INDLPL+I ) = LD( I ) / DPLUS
IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
IF( WORK( INDLPL+I ).EQ.ZERO )
$ WORK( INDS+I ) = LLD( I )
S = WORK( INDS+I ) - LAMBDA
70 CONTINUE
DO 71 I = R1, R2 - 1
DPLUS = D( I ) + S
IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
WORK( INDLPL+I ) = LD( I ) / DPLUS
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
IF( WORK( INDLPL+I ).EQ.ZERO )
$ WORK( INDS+I ) = LLD( I )
S = WORK( INDS+I ) - LAMBDA
71 CONTINUE
END IF
*
* Compute the progressive transform (using the differential form)
* until the index R1
*
SAWNAN2 = .FALSE.
NEG2 = 0
WORK( INDP+BN-1 ) = D( BN ) - LAMBDA
DO 80 I = BN - 1, R1, -1
DMINUS = LLD( I ) + WORK( INDP+I )
TMP = D( I ) / DMINUS
IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
WORK( INDUMN+I ) = L( I )*TMP
WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
80 CONTINUE
TMP = WORK( INDP+R1-1 )
SAWNAN2 = DISNAN( TMP )
IF( SAWNAN2 ) THEN
* Runs a slower version of the above loop if a NaN is detected
NEG2 = 0
DO 100 I = BN-1, R1, -1
DMINUS = LLD( I ) + WORK( INDP+I )
IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN
TMP = D( I ) / DMINUS
IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
WORK( INDUMN+I ) = L( I )*TMP
WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
IF( TMP.EQ.ZERO )
$ WORK( INDP+I-1 ) = D( I ) - LAMBDA
100 CONTINUE
END IF
*
* Find the index (from R1 to R2) of the largest (in magnitude)
* diagonal element of the inverse
*
MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1
IF( WANTNC ) THEN
NEGCNT = NEG1 + NEG2
ELSE
NEGCNT = -1
ENDIF
IF( ABS(MINGMA).EQ.ZERO )
$ MINGMA = EPS*WORK( INDS+R1-1 )
R = R1
DO 110 I = R1, R2 - 1
TMP = WORK( INDS+I ) + WORK( INDP+I )
IF( TMP.EQ.ZERO )
$ TMP = EPS*WORK( INDS+I )
IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN
MINGMA = TMP
R = I + 1
END IF
110 CONTINUE
*
* Compute the FP vector: solve N^T v = e_r
*
ISUPPZ( 1 ) = B1
ISUPPZ( 2 ) = BN
Z( R ) = CONE
ZTZ = ONE
*
* Compute the FP vector upwards from R
*
IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
DO 210 I = R-1, B1, -1
Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I ) = ZERO
ISUPPZ( 1 ) = I + 1
GOTO 220
ENDIF
ZTZ = ZTZ + DBLE( Z( I )*Z( I ) )
210 CONTINUE
220 CONTINUE
ELSE
* Run slower loop if NaN occurred.
DO 230 I = R - 1, B1, -1
IF( Z( I+1 ).EQ.ZERO ) THEN
Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
ELSE
Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
END IF
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I ) = ZERO
ISUPPZ( 1 ) = I + 1
GO TO 240
END IF
ZTZ = ZTZ + DBLE( Z( I )*Z( I ) )
230 CONTINUE
240 CONTINUE
ENDIF
* Compute the FP vector downwards from R in blocks of size BLKSIZ
IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
DO 250 I = R, BN-1
Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I+1 ) = ZERO
ISUPPZ( 2 ) = I
GO TO 260
END IF
ZTZ = ZTZ + DBLE( Z( I+1 )*Z( I+1 ) )
250 CONTINUE
260 CONTINUE
ELSE
* Run slower loop if NaN occurred.
DO 270 I = R, BN - 1
IF( Z( I ).EQ.ZERO ) THEN
Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
ELSE
Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
END IF
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I+1 ) = ZERO
ISUPPZ( 2 ) = I
GO TO 280
END IF
ZTZ = ZTZ + DBLE( Z( I+1 )*Z( I+1 ) )
270 CONTINUE
280 CONTINUE
END IF
*
* Compute quantities for convergence test
*
TMP = ONE / ZTZ
NRMINV = SQRT( TMP )
RESID = ABS( MINGMA )*NRMINV
RQCORR = MINGMA*TMP
*
*
RETURN
*
* End of ZLAR1V
*
END
SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZUNM2L overwrites the general complex m-by-n matrix C with
*
* Q * C if SIDE = 'L' and TRANS = 'N', or
*
* Q'* C if SIDE = 'L' and TRANS = 'C', or
*
* C * Q if SIDE = 'R' and TRANS = 'N', or
*
* C * Q' if SIDE = 'R' and TRANS = 'C',
*
* where Q is a complex unitary matrix defined as the product of k
* elementary reflectors
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n
* if SIDE = 'R'.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': apply Q or Q' from the Left
* = 'R': apply Q or Q' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply Q (No transpose)
* = 'C': apply Q' (Conjugate transpose)
*
* M (input) INTEGER
* The number of rows of the matrix C. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix C. N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines
* the matrix Q.
* If SIDE = 'L', M >= K >= 0;
* if SIDE = 'R', N >= K >= 0.
*
* A (input) COMPLEX*16 array, dimension (LDA,K)
* The i-th column must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* ZGEQLF 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) COMPLEX*16 array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by ZGEQLF.
*
* C (input/output) COMPLEX*16 array, dimension (LDC,N)
* On entry, the m-by-n matrix C.
* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace) COMPLEX*16 array, dimension
* (N) if SIDE = 'L',
* (M) if SIDE = 'R'
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
COMPLEX*16 AII, TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ is the order of Q
*
IF( LEFT ) THEN
NQ = M
ELSE
NQ = N
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNM2L', -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) or H(i)' is applied to C(1:m-k+i,1:n)
*
MI = M - K + I
ELSE
*
* H(i) or H(i)' is applied to C(1:m,1:n-k+i)
*
NI = N - K + I
END IF
*
* Apply H(i) or H(i)'
*
IF( NOTRAN ) THEN
TAUI = TAU( I )
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
AII = A( NQ-K+I, I )
A( NQ-K+I, I ) = ONE
CALL ZLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK )
A( NQ-K+I, I ) = AII
10 CONTINUE
RETURN
*
* End of ZUNM2L
*
END
SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIRECT, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* Purpose
* =======
*
* ZLARFT forms the triangular factor T of a complex block reflector H
* of order n, which is defined as a product of k elementary reflectors.
*
* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
*
* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
*
* If STOREV = 'C', the vector which defines the elementary reflector
* H(i) is stored in the i-th column of the array V, and
*
* H = I - V * T * V'
*
* If STOREV = 'R', the vector which defines the elementary reflector
* H(i) is stored in the i-th row of the array V, and
*
* H = I - V' * T * V
*
* Arguments
* =========
*
* DIRECT (input) CHARACTER*1
* Specifies the order in which the elementary reflectors are
* multiplied to form the block reflector:
* = 'F': H = H(1) H(2) . . . H(k) (Forward)
* = 'B': H = H(k) . . . H(2) H(1) (Backward)
*
* STOREV (input) CHARACTER*1
* Specifies how the vectors which define the elementary
* reflectors are stored (see also Further Details):
* = 'C': columnwise
* = 'R': rowwise
*
* N (input) INTEGER
* The order of the block reflector H. N >= 0.
*
* K (input) INTEGER
* The order of the triangular factor T (= the number of
* elementary reflectors). K >= 1.
*
* V (input/output) COMPLEX*16 array, dimension
* (LDV,K) if STOREV = 'C'
* (LDV,N) if STOREV = 'R'
* The matrix V. See further details.
*
* LDV (input) INTEGER
* The leading dimension of the array V.
* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
*
* TAU (input) COMPLEX*16 array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i).
*
* T (output) COMPLEX*16 array, dimension (LDT,K)
* The k by k triangular factor T of the block reflector.
* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
* lower triangular. The rest of the array is not used.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= K.
*
* Further Details
* ===============
*
* The shape of the matrix V and the storage of the vectors which define
* the H(i) is best illustrated by the following example with n = 5 and
* k = 3. The elements equal to 1 are not stored; the corresponding
* array elements are modified but restored on exit. The rest of the
* array is not used.
*
* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*
* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
* ( v1 1 ) ( 1 v2 v2 v2 )
* ( v1 v2 1 ) ( 1 v3 v3 )
* ( v1 v2 v3 )
* ( v1 v2 v3 )
*
* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*
* V = ( v1 v2 v3 ) V = ( v1 v1 1 )
* ( v1 v2 v3 ) ( v2 v2 v2 1 )
* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
* ( 1 v3 )
* ( 1 )
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, J, PREVLASTV, LASTV
COMPLEX*16 VII
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZLACGV, ZTRMV
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
PREVLASTV = N
DO 20 I = 1, K
PREVLASTV = MAX( PREVLASTV, I )
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
! Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i)
*
CALL ZGEMV( 'Conjugate transpose', J-I+1, I-1,
$ -TAU( I ), V( I, 1 ), LDV, V( I, I ), 1,
$ ZERO, T( 1, I ), 1 )
ELSE
! Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)'
*
IF( I.LT.J )
$ CALL ZLACGV( J-I, V( I, I+1 ), LDV )
CALL ZGEMV( 'No transpose', I-1, J-I+1, -TAU( I ),
$ V( 1, I ), LDV, V( I, I ), LDV, ZERO,
$ T( 1, I ), 1 )
IF( I.LT.J )
$ CALL ZLACGV( J-I, V( I, I+1 ), LDV )
END IF
V( I, I ) = VII
*
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
*
CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
$ LDT, T( 1, I ), 1 )
T( I, I ) = TAU( I )
IF( I.GT.1 ) THEN
PREVLASTV = MAX( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
20 CONTINUE
ELSE
PREVLASTV = 1
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
! Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) :=
* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i)
*
CALL ZGEMV( 'Conjugate transpose', N-K+I-J+1, K-I,
$ -TAU( I ), V( J, I+1 ), LDV, V( J, 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
! Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) :=
* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)'
*
CALL ZLACGV( N-K+I-1-J+1, V( I, J ), LDV )
CALL ZGEMV( 'No transpose', K-I, N-K+I-J+1,
$ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV,
$ ZERO, T( I+1, I ), 1 )
CALL ZLACGV( N-K+I-1-J+1, V( I, J ), LDV )
V( I, N-K+I ) = VII
END IF
*
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
*
CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
IF( I.GT.1 ) THEN
PREVLASTV = MIN( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
T( I, I ) = TAU( I )
END IF
40 CONTINUE
END IF
RETURN
*
* End of ZLARFT
*
END
SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* Purpose
* =======
*
* ZLARFB applies a complex block reflector H or its transpose H' to a
* complex M-by-N matrix C, from either the left or the right.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': apply H or H' from the Left
* = 'R': apply H or H' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply H (No transpose)
* = 'C': apply H' (Conjugate transpose)
*
* DIRECT (input) CHARACTER*1
* Indicates how H is formed from a product of elementary
* reflectors
* = 'F': H = H(1) H(2) . . . H(k) (Forward)
* = 'B': H = H(k) . . . H(2) H(1) (Backward)
*
* STOREV (input) CHARACTER*1
* Indicates how the vectors which define the elementary
* reflectors are stored:
* = 'C': Columnwise
* = 'R': Rowwise
*
* M (input) INTEGER
* The number of rows of the matrix C.
*
* N (input) INTEGER
* The number of columns of the matrix C.
*
* K (input) INTEGER
* The order of the matrix T (= the number of elementary
* reflectors whose product defines the block reflector).
*
* V (input) COMPLEX*16 array, dimension
* (LDV,K) if STOREV = 'C'
* (LDV,M) if STOREV = 'R' and SIDE = 'L'
* (LDV,N) if STOREV = 'R' and SIDE = 'R'
* The matrix V. See further details.
*
* LDV (input) INTEGER
* The leading dimension of the array V.
* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
* if STOREV = 'R', LDV >= K.
*
* T (input) COMPLEX*16 array, dimension (LDT,K)
* The triangular K-by-K matrix T in the representation of the
* block reflector.
*
* LDT (input) INTEGER
* The leading dimension of the array T. LDT >= K.
*
* C (input/output) COMPLEX*16 array, dimension (LDC,N)
* On entry, the M-by-N matrix C.
* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K)
*
* LDWORK (input) INTEGER
* The leading dimension of the array WORK.
* If SIDE = 'L', LDWORK >= max(1,N);
* if SIDE = 'R', LDWORK >= max(1,M).
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J, LASTV, LASTC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAZLR, ILAZLC
EXTERNAL LSAME, ILAZLR, ILAZLC
* ..
* .. External Subroutines ..
EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( LSAME( TRANS, 'N' ) ) THEN
TRANST = 'C'
ELSE
TRANST = 'N'
END IF
*
IF( LSAME( STOREV, 'C' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 ) (first K rows)
* ( V2 )
* where V1 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H' * C where C = ( C1 )
* ( C2 )
*
LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
LASTC = ILAZLC( LASTV, N, C, LDC )
*
* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
*
* W := C1'
*
DO 10 J = 1, K
CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2'*V2
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose',
$ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
$ V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W'
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2 * W'
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ LASTV-K, LASTC, K,
$ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK,
$ ONE, C( K+1, 1 ), LDC )
END IF
*
* W := W * V1'
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W'
*
DO 30 J = 1, K
DO 20 I = 1, LASTC
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
20 CONTINUE
30 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H' where C = ( C1 C2 )
*
LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
LASTC = ILAZLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL ZGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-K,
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V'
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - W * V2'
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, LASTV-K, K,
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
$ ONE, C( 1, K+1 ), LDC )
END IF
*
* W := W * V1'
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, LASTC
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 )
*
LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
LASTC = ILAZLC( LASTV, N, C, LDC )
*
* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
*
* W := C2'
*
DO 70 J = 1, K
CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1'*V1
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose',
$ LASTC, K, LASTV-K,
$ ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W'
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - V1 * W'
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ LASTV-K, LASTC, K,
$ -ONE, V, LDV, WORK, LDWORK,
$ ONE, C, LDC )
END IF
*
* W := W * V2'
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W'
*
DO 90 J = 1, K
DO 80 I = 1, LASTC
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
$ DCONJG( WORK( I, J ) )
80 CONTINUE
90 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H' where C = ( C1 C2 )
*
LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
LASTC = ILAZLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
$ WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL ZGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V'
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - W * V1'
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
$ ONE, C, LDC )
END IF
*
* W := W * V2'
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, LASTC
C( I, LASTV-K+J ) = C( I, LASTV-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 )
*
LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
LASTC = ILAZLC( LASTV, N, C, LDC )
*
* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
*
* W := C1'
*
DO 130 J = 1, K
CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1'
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2'*V2'
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTC, K, LASTV-K,
$ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V' * W'
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - V2' * W'
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTV-K, LASTC, K,
$ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
$ ONE, C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W'
*
DO 150 J = 1, K
DO 140 I = 1, LASTC
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
140 CONTINUE
150 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H' where C = ( C1 C2 )
*
LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
LASTC = ILAZLR( M, LASTV, C, LDC )
*
* W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1'
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2 * V2'
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
$ V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - W * V2
*
CALL ZGEMM( 'No transpose', 'No transpose',
$ LASTC, LASTV-K, K,
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
$ ONE, C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, LASTC
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 )
*
LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
LASTC = ILAZLC( LASTV, N, C, LDC )
*
* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
*
* W := C2'
*
DO 190 J = 1, K
CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2'
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1'*V1'
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTC, K, LASTV-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V' * W'
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - V1' * W'
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', LASTV-K, LASTC, K,
$ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W'
*
DO 210 J = 1, K
DO 200 I = 1, LASTC
C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
$ DCONJG( WORK( I, J ) )
200 CONTINUE
210 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H' where C = ( C1 C2 )
*
LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
LASTC = ILAZLR( M, LASTV, C, LDC )
*
* W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
$ WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2'
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1 * V1'
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE,
$ WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - W * V1
*
CALL ZGEMM( 'No transpose', 'No transpose',
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
$ ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, LASTC
C( I, LASTV-K+J ) = C( I, LASTV-K+J )
$ - WORK( I, J )
230 CONTINUE
240 CONTINUE
*
END IF
*
END IF
END IF
*
RETURN
*
* End of ZLARFB
*
END
SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZUNM2R overwrites the general complex m-by-n matrix C with
*
* Q * C if SIDE = 'L' and TRANS = 'N', or
*
* Q'* C if SIDE = 'L' and TRANS = 'C', or
*
* C * Q if SIDE = 'R' and TRANS = 'N', or
*
* C * Q' if SIDE = 'R' and TRANS = 'C',
*
* where Q is a complex unitary matrix defined as the product of k
* elementary reflectors
*
* Q = H(1) H(2) . . . H(k)
*
* as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n
* if SIDE = 'R'.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': apply Q or Q' from the Left
* = 'R': apply Q or Q' from the Right
*
* TRANS (input) CHARACTER*1
* = 'N': apply Q (No transpose)
* = 'C': apply Q' (Conjugate transpose)
*
* M (input) INTEGER
* The number of rows of the matrix C. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix C. N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines
* the matrix Q.
* If SIDE = 'L', M >= K >= 0;
* if SIDE = 'R', N >= K >= 0.
*
* A (input) COMPLEX*16 array, dimension (LDA,K)
* The i-th column must contain the vector which defines the
* elementary reflector H(i), for i = 1,2,...,k, as returned by
* ZGEQRF in the first k columns of its array argument A.
* A is modified by the routine but restored on exit.
*
* LDA (input) INTEGER
* The leading dimension of the array A.
* If SIDE = 'L', LDA >= max(1,M);
* if SIDE = 'R', LDA >= max(1,N).
*
* TAU (input) COMPLEX*16 array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by ZGEQRF.
*
* C (input/output) COMPLEX*16 array, dimension (LDC,N)
* On entry, the m-by-n matrix C.
* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace) COMPLEX*16 array, dimension
* (N) if SIDE = 'L',
* (M) if SIDE = 'R'
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
COMPLEX*16 AII, TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ is the order of Q
*
IF( LEFT ) THEN
NQ = M
ELSE
NQ = N
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNM2R', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = 1
ELSE
I1 = K
I2 = 1
I3 = -1
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) or H(i)' is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H(i) or H(i)' is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H(i) or H(i)'
*
IF( NOTRAN ) THEN
TAUI = TAU( I )
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
AII = A( I, I )
A( I, I ) = ONE
CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC,
$ WORK )
A( I, I ) = AII
10 CONTINUE
RETURN
*
* End of ZUNM2R
*
END
SUBROUTINE DLARUV( ISEED, N, X )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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 )
*
20 CONTINUE
*
* 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 ) ) ) )
*
IF (X( I ).EQ.1.0D0) THEN
* If a real number has n bits of precision, and the first
* n bits of the 48-bit integer above happen to be all 1 (which
* will occur about once every 2**n calls), then X( I ) will
* be rounded to exactly 1.0.
* Since X( I ) is not supposed to return exactly 0.0 or 1.0,
* the statistically correct thing to do in this situation is
* simply to iterate again.
* N.B. the case X( I ) = 0.0 should not be possible.
I1 = I1 + 2
I2 = I2 + 2
I3 = I3 + 2
I4 = I4 + 2
GOTO 20
END IF
*
10 CONTINUE
*
* Return final value of seed
*
ISEED( 1 ) = IT1
ISEED( 2 ) = IT2
ISEED( 3 ) = IT3
ISEED( 4 ) = IT4
RETURN
*
* End of DLARUV
*
END
INTEGER FUNCTION ILAZLC( M, N, A, LDA )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2.2) --
*
* -- June 2010 --
*
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* Purpose
* =======
*
* ILAZLC scans A for its last non-zero column.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of the matrix A.
*
* A (input) COMPLEX*16 array, dimension (LDA,N)
* The m by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( N.EQ.0 ) THEN
ILAZLC = N
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILAZLC = N
ELSE
* Now scan each column from the end, returning with the first non-zero.
DO ILAZLC = N, 1, -1
DO I = 1, M
IF( A(I, ILAZLC).NE.ZERO ) RETURN
END DO
END DO
END IF
RETURN
END
INTEGER FUNCTION ILAZLR( M, N, A, LDA )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2.2) --
*
* -- June 2010 --
*
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* Purpose
* =======
*
* ILAZLR scans A for its last non-zero row.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of the matrix A.
*
* A (input) COMPLEX*16 array, dimension (LDA,N)
* The m by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( M.EQ.0 ) THEN
ILAZLR = M
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILAZLR = M
ELSE
* Scan up each column tracking the last zero row seen.
ILAZLR = 0
DO J = 1, N
DO I = M, 1, -1
IF( A(I, J).NE.ZERO ) EXIT
END DO
ILAZLR = MAX( ILAZLR, I )
END DO
END IF
RETURN
END
LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 )
*
* -- LAPACK auxiliary routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
*
* .. Scalar Arguments ..
DOUBLE PRECISION DIN1, DIN2
* ..
*
* Purpose
* =======
*
* This routine is not for general use. It exists solely to avoid
* over-optimization in DISNAN.
*
* DLAISNAN checks for NaNs by comparing its two arguments for
* inequality. NaN is the only floating-point value where NaN != NaN
* returns .TRUE. To check for NaNs, pass the same variable as both
* arguments.
*
* A compiler must assume that the two arguments are
* not the same variable, and the test will not be optimized away.
* Interprocedural or whole-program optimization may delete this
* test. The ISNAN functions will be replaced by the correct
* Fortran 03 intrinsic once the intrinsic is widely available.
*
* Arguments
* =========
*
* DIN1 (input) DOUBLE PRECISION
*
* DIN2 (input) DOUBLE PRECISION
* Two numbers to compare for inequality.
*
* =====================================================================
*
* .. Executable Statements ..
DLAISNAN = (DIN1.NE.DIN2)
RETURN
END
SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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' ) / DLAMCH( 'E' )
KNT = 0
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
RSAFMN = ONE / SAFMIN
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 )
END IF
TAU = ( BETA-ALPHA ) / BETA
CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
DO 20 J = 1, KNT
BETA = BETA*SAFMIN
20 CONTINUE
ALPHA = BETA
END IF
*
RETURN
*
* End of DLARFG
*
END
SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
CHARACTER DIRECT, PIVOT, SIDE
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( * ), S( * )
* ..
*
* Purpose
* =======
*
* DLASR applies a sequence of plane rotations to a real matrix A,
* from either the left or the right.
*
* When SIDE = 'L', the transformation takes the form
*
* A := P*A
*
* and when SIDE = 'R', the transformation takes the form
*
* A := A*P**T
*
* where P is an orthogonal matrix consisting of a sequence of z plane
* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
* and P**T is the transpose of P.
*
* When DIRECT = 'F' (Forward sequence), then
*
* P = P(z-1) * ... * P(2) * P(1)
*
* and when DIRECT = 'B' (Backward sequence), then
*
* P = P(1) * P(2) * ... * P(z-1)
*
* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
*
* R(k) = ( c(k) s(k) )
* = ( -s(k) c(k) ).
*
* When PIVOT = 'V' (Variable pivot), the rotation is performed
* for the plane (k,k+1), i.e., P(k) has the form
*
* P(k) = ( 1 )
* ( ... )
* ( 1 )
* ( c(k) s(k) )
* ( -s(k) c(k) )
* ( 1 )
* ( ... )
* ( 1 )
*
* where R(k) appears as a rank-2 modification to the identity matrix in
* rows and columns k and k+1.
*
* When PIVOT = 'T' (Top pivot), the rotation is performed for the
* plane (1,k+1), so P(k) has the form
*
* P(k) = ( c(k) s(k) )
* ( 1 )
* ( ... )
* ( 1 )
* ( -s(k) c(k) )
* ( 1 )
* ( ... )
* ( 1 )
*
* where R(k) appears in rows and columns 1 and k+1.
*
* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
* performed for the plane (k,z), giving P(k) the form
*
* P(k) = ( 1 )
* ( ... )
* ( 1 )
* ( c(k) s(k) )
* ( 1 )
* ( ... )
* ( 1 )
* ( -s(k) c(k) )
*
* where R(k) appears in rows and columns k and z. The rotations are
* performed without ever forming P(k) explicitly.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* Specifies whether the plane rotation matrix P is applied to
* A on the left or the right.
* = 'L': Left, compute A := P*A
* = 'R': Right, compute A:= A*P**T
*
* PIVOT (input) CHARACTER*1
* Specifies the plane for which P(k) is a plane rotation
* matrix.
* = 'V': Variable pivot, the plane (k,k+1)
* = 'T': Top pivot, the plane (1,k+1)
* = 'B': Bottom pivot, the plane (k,z)
*
* DIRECT (input) CHARACTER*1
* Specifies whether P is a forward or backward sequence of
* plane rotations.
* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)
* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)
*
* M (input) INTEGER
* The number of rows of the matrix A. If m <= 1, an immediate
* return is effected.
*
* N (input) INTEGER
* The number of columns of the matrix A. If n <= 1, an
* immediate return is effected.
*
* C (input) DOUBLE PRECISION array, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* The cosines c(k) of the plane rotations.
*
* S (input) DOUBLE PRECISION array, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* The sines s(k) of the plane rotations. The 2-by-2 plane
* rotation part of the matrix P(k), R(k), has the form
* R(k) = ( c(k) s(k) )
* ( -s(k) c(k) ).
*
* A (input/output) 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**T if SIDE = 'L'.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
DOUBLE PRECISION CTEMP, STEMP, 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
SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER CUTPNT, INFO, LDQ, N
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER INDXQ( * ), IWORK( * )
DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLAED1 computes the updated eigensystem of a diagonal
* matrix after modification by a rank-one symmetric matrix. This
* routine is used only for the eigenproblem which requires all
* eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles
* the case in which eigenvalues only or eigenvalues and eigenvectors
* of a full symmetric matrix (which was reduced to tridiagonal form)
* are desired.
*
* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
* where Z = Q'u, u is a vector of length N with ones in the
* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*
* The eigenvectors of the original matrix are stored in Q, and the
* eigenvalues are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple eigenvalues or if there is a zero in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine DLAED2.
*
* The second stage consists of calculating the updated
* eigenvalues. This is done by finding the roots of the secular
* equation via the routine DLAED4 (as called by DLAED3).
* This routine also calculates the eigenvectors of the current
* problem.
*
* The final stage consists of computing the updated eigenvectors
* directly using the updated eigenvalues. The eigenvectors for
* the current problem are multiplied with the eigenvectors from
* the overall problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the eigenvalues of the rank-1-perturbed matrix.
* On exit, the eigenvalues of the repaired matrix.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
* On entry, the eigenvectors of the rank-1-perturbed matrix.
* On exit, the eigenvectors of the repaired tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input/output) INTEGER array, dimension (N)
* On entry, the permutation which separately sorts the two
* subproblems in D into ascending order.
* On exit, the permutation which will reintegrate the
* subproblems back into sorted order,
* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
*
* RHO (input) DOUBLE PRECISION
* The subdiagonal entry used to create the rank-1 modification.
*
* CUTPNT (input) INTEGER
* The location of the last eigenvalue in the leading sub-matrix.
* min(1,N) <= CUTPNT <= N/2.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N + N**2)
*
* IWORK (workspace) INTEGER array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,
$ IW, IZ, K, N1, N2, ZPP1
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED1', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are integer pointers which indicate
* the portion of the workspace
* used by a particular array in DLAED2 and DLAED3.
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ2 = IW + N
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )
ZPP1 = CUTPNT + 1
CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )
*
* Deflate eigenvalues.
*
CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),
$ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),
$ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),
$ IWORK( COLTYP ), INFO )
*
IF( INFO.NE.0 )
$ GO TO 20
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +
$ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2
CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),
$ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),
$ WORK( IW ), WORK( IS ), INFO )
IF( INFO.NE.0 )
$ GO TO 20
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
DO 10 I = 1, N
INDXQ( I ) = I
10 CONTINUE
END IF
*
20 CONTINUE
RETURN
*
* End of DLAED1
*
END
SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
$ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,
$ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,
$ INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
$ QSIZ, TLVLS
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
$ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
$ QSTORE( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* DLAED7 computes the updated eigensystem of a diagonal
* matrix after modification by a rank-one symmetric matrix. This
* routine is used only for the eigenproblem which requires all
* eigenvalues and optionally eigenvectors of a dense symmetric matrix
* that has been reduced to tridiagonal form. DLAED1 handles
* the case in which all eigenvalues and eigenvectors of a symmetric
* tridiagonal matrix are desired.
*
* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
* where Z = Q'u, u is a vector of length N with ones in the
* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*
* The eigenvectors of the original matrix are stored in Q, and the
* eigenvalues are in D. The algorithm consists of three stages:
*
* The first stage consists of deflating the size of the problem
* when there are multiple eigenvalues or if there is a zero in
* the Z vector. For each such occurence the dimension of the
* secular equation problem is reduced by one. This stage is
* performed by the routine DLAED8.
*
* The second stage consists of calculating the updated
* eigenvalues. This is done by finding the roots of the secular
* equation via the routine DLAED4 (as called by DLAED9).
* This routine also calculates the eigenvectors of the current
* problem.
*
* The final stage consists of computing the updated eigenvectors
* directly using the updated eigenvalues. The eigenvectors for
* the current problem are multiplied with the eigenvectors from
* the overall problem.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* TLVLS (input) INTEGER
* The total number of merging levels in the overall divide and
* conquer tree.
*
* CURLVL (input) INTEGER
* The current level in the overall merge routine,
* 0 <= CURLVL <= TLVLS.
*
* CURPBM (input) INTEGER
* The current problem in the current level in the overall
* merge routine (counting from upper left to lower right).
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the eigenvalues of the rank-1-perturbed matrix.
* On exit, the eigenvalues of the repaired matrix.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* On entry, the eigenvectors of the rank-1-perturbed matrix.
* On exit, the eigenvectors of the repaired tridiagonal matrix.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (output) INTEGER array, dimension (N)
* The permutation which will reintegrate the subproblem just
* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
* will be in ascending order.
*
* RHO (input) DOUBLE PRECISION
* The subdiagonal element used to create the rank-1
* modification.
*
* CUTPNT (input) INTEGER
* Contains the location of the last eigenvalue in the leading
* sub-matrix. min(1,N) <= CUTPNT <= N.
*
* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)
* Stores eigenvectors of submatrices encountered during
* divide and conquer, packed together. QPTR points to
* beginning of the submatrices.
*
* QPTR (input/output) INTEGER array, dimension (N+2)
* List of indices pointing to beginning of submatrices stored
* in QSTORE. The submatrices are numbered starting at the
* bottom left of the divide and conquer tree, from left to
* right and bottom to top.
*
* PRMPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in PERM a
* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
* indicates the size of the permutation and also the size of
* the full, non-deflated problem.
*
* PERM (input) INTEGER array, dimension (N lg N)
* Contains the permutations (from deflation and sorting) to be
* applied to each eigenblock.
*
* GIVPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in GIVCOL a
* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
* indicates the number of Givens rotations.
*
* GIVCOL (input) INTEGER array, dimension (2, N lg N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N)
*
* IWORK (workspace) INTEGER array, dimension (4*N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
$ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED7', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in DLAED8 and DLAED9.
*
IF( ICOMPQ.EQ.1 ) THEN
LDQ2 = QSIZ
ELSE
LDQ2 = N
END IF
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ2 = IW + N
IS = IQ2 + N*LDQ2
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
PTR = 1 + 2**TLVLS
DO 10 I = 1, CURLVL - 1
PTR = PTR + 2**( TLVLS-I )
10 CONTINUE
CURR = PTR + CURPBM
CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),
$ WORK( IZ+N ), INFO )
*
* When solving the final problem, we no longer need the stored data,
* so we will overwrite the data from this level onto the previously
* used storage space.
*
IF( CURLVL.EQ.TLVLS ) THEN
QPTR( CURR ) = 1
PRMPTR( CURR ) = 1
GIVPTR( CURR ) = 1
END IF
*
* Sort and Deflate eigenvalues.
*
CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,
$ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,
$ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
$ GIVCOL( 1, GIVPTR( CURR ) ),
$ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),
$ IWORK( INDX ), INFO )
PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),
$ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( ICOMPQ.EQ.1 ) THEN
CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,
$ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )
END IF
QPTR( CURR+1 ) = QPTR( CURR ) + K**2
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
QPTR( CURR+1 ) = QPTR( CURR )
DO 20 I = 1, N
INDXQ( I ) = I
20 CONTINUE
END IF
*
30 CONTINUE
RETURN
*
* End of DLAED7
*
END
SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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
SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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, PREVLASTV, LASTV
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
PREVLASTV = N
DO 20 I = 1, K
PREVLASTV = MAX( I, PREVLASTV )
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
! Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i)
*
CALL DGEMV( 'Transpose', J-I+1, I-1, -TAU( I ),
$ V( I, 1 ), LDV, V( I, I ), 1, ZERO,
$ T( 1, I ), 1 )
ELSE
! Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)'
*
CALL DGEMV( 'No transpose', I-1, J-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 )
IF( I.GT.1 ) THEN
PREVLASTV = MAX( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
20 CONTINUE
ELSE
PREVLASTV = 1
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
! Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) :=
* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i)
*
CALL DGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ),
$ V( J, I+1 ), LDV, V( J, 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
! Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) :=
* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)'
*
CALL DGEMV( 'No transpose', K-I, N-K+I-J+1,
$ -TAU( I ), V( I+1, J ), LDV, V( I, J ), 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 )
IF( I.GT.1 ) THEN
PREVLASTV = MIN( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
T( I, I ) = TAU( I )
END IF
40 CONTINUE
END IF
RETURN
*
* End of DLARFT
*
END
SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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, LASTV, LASTC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILADLR, ILADLC
EXTERNAL LSAME, ILADLR, ILADLC
* ..
* .. 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 )
*
LASTV = MAX( K, ILADLR( M, K, V, LDV ) )
LASTC = ILADLC( LASTV, N, C, LDC )
*
* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
*
* W := C1'
*
DO 10 J = 1, K
CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2'*V2
*
CALL DGEMM( 'Transpose', 'No transpose',
$ LASTC, K, LASTV-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',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W'
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - V2 * W'
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTV-K, LASTC, 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',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W'
*
DO 30 J = 1, K
DO 20 I = 1, LASTC
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 )
*
LASTV = MAX( K, ILADLR( N, K, V, LDV ) )
LASTC = ILADLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL DGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-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',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V'
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - W * V2'
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTC, LASTV-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',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, LASTC
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 )
*
LASTV = MAX( K, ILADLR( M, K, V, LDV ) )
LASTC = ILADLC( LASTV, N, C, LDC )
*
* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
*
* W := C2'
*
DO 70 J = 1, K
CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1'*V1
*
CALL DGEMM( 'Transpose', 'No transpose',
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W'
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - V1 * W'
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
$ ONE, C, LDC )
END IF
*
* W := W * V2'
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W'
*
DO 90 J = 1, K
DO 80 I = 1, LASTC
C( LASTV-K+J, I ) = C( LASTV-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 )
*
LASTV = MAX( K, ILADLR( N, K, V, LDV ) )
LASTC = ILADLR( M, LASTV, C, LDC )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL DGEMM( 'No transpose', 'No transpose',
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V'
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - W * V1'
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
$ ONE, C, LDC )
END IF
*
* W := W * V2'
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, LASTC
C( I, LASTV-K+J ) = C( I, LASTV-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 )
*
LASTV = MAX( K, ILADLC( K, M, V, LDV ) )
LASTC = ILADLC( LASTV, N, C, LDC )
*
* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
*
* W := C1'
*
DO 130 J = 1, K
CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1'
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2'*V2'
*
CALL DGEMM( 'Transpose', 'Transpose',
$ LASTC, K, LASTV-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',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V' * W'
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - V2' * W'
*
CALL DGEMM( 'Transpose', 'Transpose',
$ LASTV-K, LASTC, 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',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W'
*
DO 150 J = 1, K
DO 140 I = 1, LASTC
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 )
*
LASTV = MAX( K, ILADLC( K, N, V, LDV ) )
LASTC = ILADLR( M, LASTV, C, LDC )
*
* W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1'
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C2 * V2'
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTC, K, LASTV-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',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( LASTV.GT.K ) THEN
*
* C2 := C2 - W * V2
*
CALL DGEMM( 'No transpose', 'No transpose',
$ LASTC, LASTV-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',
$ LASTC, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, LASTC
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 )
*
LASTV = MAX( K, ILADLC( K, M, V, LDV ) )
LASTC = ILADLC( LASTV, N, C, LDC )
*
* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
*
* W := C2'
*
DO 190 J = 1, K
CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
$ WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2'
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1'*V1'
*
CALL DGEMM( 'Transpose', 'Transpose',
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T' or W * T
*
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - V' * W'
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - V1' * W'
*
CALL DGEMM( 'Transpose', 'Transpose',
$ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
$ ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
*
* C2 := C2 - W'
*
DO 210 J = 1, K
DO 200 I = 1, LASTC
C( LASTV-K+J, I ) = C( LASTV-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 )
*
LASTV = MAX( K, ILADLC( K, N, V, LDV ) )
LASTC = ILADLR( M, LASTV, C, LDC )
*
* W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1,
$ WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2'
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
IF( LASTV.GT.K ) THEN
*
* W := W + C1 * V1'
*
CALL DGEMM( 'No transpose', 'Transpose',
$ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T'
*
CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
$ LASTC, K, ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( LASTV.GT.K ) THEN
*
* C1 := C1 - W * V1
*
CALL DGEMM( 'No transpose', 'No transpose',
$ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
$ ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
$ WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, LASTC
C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J)
230 CONTINUE
240 CONTINUE
*
END IF
*
END IF
END IF
*
RETURN
*
* End of DLARFB
*
END
SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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
SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, D, P, Q
* ..
*
* Purpose
* =======
*
* DLADIV performs complex division in real arithmetic
*
* a + i*b
* p + i*q = ---------
* c + i*d
*
* The algorithm is due to Robert L. Smith and can be found
* in D. Knuth, The art of Computer Programming, Vol.2, p.195
*
* Arguments
* =========
*
* A (input) DOUBLE PRECISION
* B (input) DOUBLE PRECISION
* C (input) DOUBLE PRECISION
* D (input) DOUBLE PRECISION
* The scalars a, b, c, and d in the above expression.
*
* P (output) DOUBLE PRECISION
* Q (output) DOUBLE PRECISION
* The scalars p and q in the above expression.
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION E, F
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IF( ABS( D ).LT.ABS( C ) ) THEN
E = D / C
F = C + D*E
P = ( A+B*E ) / F
Q = ( B-A*E ) / F
ELSE
E = C / D
F = D + C*E
P = ( B+A*E ) / F
Q = ( -A+B*E ) / F
END IF
*
RETURN
*
* End of DLADIV
*
END
INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
*
* .. Scalar Arguments ..
INTEGER N, R
DOUBLE PRECISION PIVMIN, SIGMA
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), LLD( * )
* ..
*
* Purpose
* =======
*
* DLANEG computes the Sturm count, the number of negative pivots
* encountered while factoring tridiagonal T - sigma I = L D L^T.
* This implementation works directly on the factors without forming
* the tridiagonal matrix T. The Sturm count is also the number of
* eigenvalues of T less than sigma.
*
* This routine is called from DLARRB.
*
* The current routine does not use the PIVMIN parameter but rather
* requires IEEE-754 propagation of Infinities and NaNs. This
* routine also has no input range restrictions but does require
* default exception handling such that x/0 produces Inf when x is
* non-zero, and Inf/Inf produces NaN. For more information, see:
*
* Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in
* Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on
* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624
* (Tech report version in LAWN 172 with the same title.)
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The N diagonal elements of the diagonal matrix D.
*
* LLD (input) DOUBLE PRECISION array, dimension (N-1)
* The (N-1) elements L(i)*L(i)*D(i).
*
* SIGMA (input) DOUBLE PRECISION
* Shift amount in T - sigma I = L D L^T.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence. May be used
* when zero pivots are encountered on non-IEEE-754
* architectures.
*
* R (input) INTEGER
* The twist index for the twisted factorization that is used
* for the negcount.
*
* Further Details
* ===============
*
* Based on contributions by
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
* Jason Riedy, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* Some architectures propagate Infinities and NaNs very slowly, so
* the code computes counts in BLKLEN chunks. Then a NaN can
* propagate at most BLKLEN columns before being detected. This is
* not a general tuning parameter; it needs only to be just large
* enough that the overhead is tiny in common cases.
INTEGER BLKLEN
PARAMETER ( BLKLEN = 128 )
* ..
* .. Local Scalars ..
INTEGER BJ, J, NEG1, NEG2, NEGCNT
DOUBLE PRECISION BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP
LOGICAL SAWNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN, MAX
* ..
* .. External Functions ..
LOGICAL DISNAN
EXTERNAL DISNAN
* ..
* .. Executable Statements ..
NEGCNT = 0
* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
T = -SIGMA
DO 210 BJ = 1, R-1, BLKLEN
NEG1 = 0
BSAV = T
DO 21 J = BJ, MIN(BJ+BLKLEN-1, R-1)
DPLUS = D( J ) + T
IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
TMP = T / DPLUS
T = TMP * LLD( J ) - SIGMA
21 CONTINUE
SAWNAN = DISNAN( T )
* Run a slower version of the above loop if a NaN is detected.
* A NaN should occur only with a zero pivot after an infinite
* pivot. In that case, substituting 1 for T/DPLUS is the
* correct limit.
IF( SAWNAN ) THEN
NEG1 = 0
T = BSAV
DO 22 J = BJ, MIN(BJ+BLKLEN-1, R-1)
DPLUS = D( J ) + T
IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
TMP = T / DPLUS
IF (DISNAN(TMP)) TMP = ONE
T = TMP * LLD(J) - SIGMA
22 CONTINUE
END IF
NEGCNT = NEGCNT + NEG1
210 CONTINUE
*
* II) lower part: L D L^T - SIGMA I = U- D- U-^T
P = D( N ) - SIGMA
DO 230 BJ = N-1, R, -BLKLEN
NEG2 = 0
BSAV = P
DO 23 J = BJ, MAX(BJ-BLKLEN+1, R), -1
DMINUS = LLD( J ) + P
IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
TMP = P / DMINUS
P = TMP * D( J ) - SIGMA
23 CONTINUE
SAWNAN = DISNAN( P )
* As above, run a slower version that substitutes 1 for Inf/Inf.
*
IF( SAWNAN ) THEN
NEG2 = 0
P = BSAV
DO 24 J = BJ, MAX(BJ-BLKLEN+1, R), -1
DMINUS = LLD( J ) + P
IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
TMP = P / DMINUS
IF (DISNAN(TMP)) TMP = ONE
P = TMP * D(J) - SIGMA
24 CONTINUE
END IF
NEGCNT = NEGCNT + NEG2
230 CONTINUE
*
* III) Twist index
* T was shifted by SIGMA initially.
GAMMA = (T + SIGMA) + P
IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1
DLANEG = NEGCNT
END
SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
$ DN2, G, TAU )
*
* -- LAPACK routine (version 3.2.2) --
*
* -- Contributed by Osni Marques of the Lawrence Berkeley National --
* -- Laboratory and Beresford Parlett of the Univ. of California at --
* -- Berkeley --
* -- June 2010 --
*
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER I0, ITER, N0, NDIV, NFAIL, PP
DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G,
$ QMAX, SIGMA, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
* In case of failure it changes shifts, and tries again until output
* is positive.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input/output) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input/output) INTEGER
* PP=0 for ping, PP=1 for pong.
* PP=2 indicates that flipping was applied to the Z array
* and that the initial tests for deflation should not be
* performed.
*
* DMIN (output) DOUBLE PRECISION
* Minimum value of d.
*
* SIGMA (output) DOUBLE PRECISION
* Sum of shifts used in current segment.
*
* DESIG (input/output) DOUBLE PRECISION
* Lower order part of SIGMA
*
* QMAX (input) DOUBLE PRECISION
* Maximum value of q.
*
* NFAIL (output) INTEGER
* Number of times shift was too big.
*
* ITER (output) INTEGER
* Number of iterations.
*
* NDIV (output) INTEGER
* Number of divisions.
*
* IEEE (input) LOGICAL
* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).
*
* TTYPE (input/output) INTEGER
* Shift type.
*
* DMIN1 (input/output) DOUBLE PRECISION
*
* DMIN2 (input/output) DOUBLE PRECISION
*
* DN (input/output) DOUBLE PRECISION
*
* DN1 (input/output) DOUBLE PRECISION
*
* DN2 (input/output) DOUBLE PRECISION
*
* G (input/output) DOUBLE PRECISION
*
* TAU (input/output) DOUBLE PRECISION
*
* These are passed as arguments in order to save their values
* between calls to DLASQ3.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CBIAS
PARAMETER ( CBIAS = 1.50D0 )
DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD
PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0,
$ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
INTEGER IPN4, J4, N0IN, NN, TTYPE
DOUBLE PRECISION EPS, S, T, TEMP, TOL, TOL2
* ..
* .. External Subroutines ..
EXTERNAL DLASQ4, DLASQ5, DLASQ6
* ..
* .. External Function ..
DOUBLE PRECISION DLAMCH
LOGICAL DISNAN
EXTERNAL DISNAN, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
N0IN = N0
EPS = DLAMCH( 'Precision' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
*
* Check for deflation.
*
10 CONTINUE
*
IF( N0.LT.I0 )
$ RETURN
IF( N0.EQ.I0 )
$ GO TO 20
NN = 4*N0 + PP
IF( N0.EQ.( I0+1 ) )
$ GO TO 40
*
* Check whether E(N0-1) is negligible, 1 eigenvalue.
*
IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
$ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
$ GO TO 30
*
20 CONTINUE
*
Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
N0 = N0 - 1
GO TO 10
*
* Check whether E(N0-2) is negligible, 2 eigenvalues.
*
30 CONTINUE
*
IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
$ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
$ GO TO 50
*
40 CONTINUE
*
IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
S = Z( NN-3 )
Z( NN-3 ) = Z( NN-7 )
Z( NN-7 ) = S
END IF
IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
S = Z( NN-3 )*( Z( NN-5 ) / T )
IF( S.LE.T ) THEN
S = Z( NN-3 )*( Z( NN-5 ) /
$ ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
T = Z( NN-7 ) + ( S+Z( NN-5 ) )
Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
Z( NN-7 ) = T
END IF
Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
N0 = N0 - 2
GO TO 10
*
50 CONTINUE
IF( PP.EQ.2 )
$ PP = 0
*
* Reverse the qd-array, if warranted.
*
IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( J4-3 )
Z( J4-3 ) = Z( IPN4-J4-3 )
Z( IPN4-J4-3 ) = TEMP
TEMP = Z( J4-2 )
Z( J4-2 ) = Z( IPN4-J4-2 )
Z( IPN4-J4-2 ) = TEMP
TEMP = Z( J4-1 )
Z( J4-1 ) = Z( IPN4-J4-5 )
Z( IPN4-J4-5 ) = TEMP
TEMP = Z( J4 )
Z( J4 ) = Z( IPN4-J4-4 )
Z( IPN4-J4-4 ) = TEMP
60 CONTINUE
IF( N0-I0.LE.4 ) THEN
Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
Z( 4*N0-PP ) = Z( 4*I0-PP )
END IF
DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
$ Z( 4*I0+PP+3 ) )
Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
$ Z( 4*I0-PP+4 ) )
QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
DMIN = -ZERO
END IF
END IF
*
* Choose a shift.
*
CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
$ DN2, TAU, TTYPE, G )
*
* Call dqds until DMIN > 0.
*
70 CONTINUE
*
CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, IEEE )
*
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
*
* Check status.
*
IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
*
* Success.
*
GO TO 90
*
ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
$ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
$ ABS( DN ).LT.TOL*SIGMA ) THEN
*
* Convergence hidden by negative DN.
*
Z( 4*( N0-1 )-PP+2 ) = ZERO
DMIN = ZERO
GO TO 90
ELSE IF( DMIN.LT.ZERO ) THEN
*
* TAU too big. Select new TAU and try again.
*
NFAIL = NFAIL + 1
IF( TTYPE.LT.-22 ) THEN
*
* Failed twice. Play it safe.
*
TAU = ZERO
ELSE IF( DMIN1.GT.ZERO ) THEN
*
* Late failure. Gives excellent shift.
*
TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
TTYPE = TTYPE - 11
ELSE
*
* Early failure. Divide by 4.
*
TAU = QURTR*TAU
TTYPE = TTYPE - 12
END IF
GO TO 70
ELSE IF( DISNAN( DMIN ) ) THEN
*
* NaN.
*
IF( TAU.EQ.ZERO ) THEN
GO TO 80
ELSE
TAU = ZERO
GO TO 70
END IF
ELSE
*
* Possible underflow. Play it safe.
*
GO TO 80
END IF
*
* Risk of underflow.
*
80 CONTINUE
CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
TAU = ZERO
*
90 CONTINUE
IF( TAU.LT.SIGMA ) THEN
DESIG = DESIG + TAU
T = SIGMA + DESIG
DESIG = DESIG - ( T-SIGMA )
ELSE
T = SIGMA + TAU
DESIG = SIGMA - ( T-TAU ) + DESIG
END IF
SIGMA = T
*
RETURN
*
* End of DLASQ3
*
END
SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,
$ Q2, INDX, INDXC, INDXP, COLTYP, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, N, N1
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
$ INDXQ( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ W( * ), Z( * )
* ..
*
* Purpose
* =======
*
* DLAED2 merges the two sets of eigenvalues together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* eigenvalues are close together or if there is a tiny entry in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* Arguments
* =========
*
* K (output) INTEGER
* The number of non-deflated eigenvalues, and the order of the
* related secular equation. 0 <= K <=N.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* N1 (input) INTEGER
* The location of the last eigenvalue in the leading sub-matrix.
* min(1,N) <= N1 <= N/2.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, D contains the eigenvalues of the two submatrices to
* be combined.
* On exit, D contains the trailing (N-K) updated eigenvalues
* (those which were deflated) sorted into increasing order.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
* On entry, Q contains the eigenvectors of two submatrices in
* the two square blocks with corners at (1,1), (N1,N1)
* and (N1+1, N1+1), (N,N).
* On exit, Q contains the trailing (N-K) updated eigenvectors
* (those which were deflated) in its last N-K columns.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input/output) INTEGER array, dimension (N)
* The permutation which separately sorts the two sub-problems
* in D into ascending order. Note that elements in the second
* half of this permutation must first have N1 added to their
* values. Destroyed on exit.
*
* RHO (input/output) DOUBLE PRECISION
* On entry, the off-diagonal element associated with the rank-1
* cut which originally split the two submatrices which are now
* being recombined.
* On exit, RHO has been modified to the value required by
* DLAED3.
*
* Z (input) DOUBLE PRECISION array, dimension (N)
* On entry, Z contains the updating vector (the last
* row of the first sub-eigenvector matrix and the first row of
* the second sub-eigenvector matrix).
* On exit, the contents of Z have been destroyed by the updating
* process.
*
* DLAMDA (output) DOUBLE PRECISION array, dimension (N)
* A copy of the first K eigenvalues which will be used by
* DLAED3 to form the secular equation.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first k values of the final deflation-altered z-vector
* which will be passed to DLAED3.
*
* Q2 (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)
* A copy of the first K eigenvectors which will be used by
* DLAED3 in a matrix multiply (DGEMM) to solve for the new
* eigenvectors.
*
* INDX (workspace) INTEGER array, dimension (N)
* The permutation used to sort the contents of DLAMDA into
* ascending order.
*
* INDXC (output) INTEGER array, dimension (N)
* The permutation used to arrange the columns of the deflated
* Q matrix into three groups: the first group contains non-zero
* elements only at and above N1, the second contains
* non-zero elements only below N1, and the third is dense.
*
* INDXP (workspace) INTEGER array, dimension (N)
* The permutation used to place deflated values of D at the end
* of the array. INDXP(1:K) points to the nondeflated D-values
* and INDXP(K+1:N) points to the deflated eigenvalues.
*
* COLTYP (workspace/output) INTEGER array, dimension (N)
* During execution, a label which will indicate which of the
* following types a column in the Q2 matrix is:
* 1 : non-zero in the upper half only;
* 2 : dense;
* 3 : non-zero in the lower half only;
* 4 : deflated.
* On exit, COLTYP(i) is the number of columns of type i,
* for i=1 to 4 only.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, EIGHT = 8.0D0 )
* ..
* .. Local Arrays ..
INTEGER CTOT( 4 ), PSM( 4 )
* ..
* .. Local Scalars ..
INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
$ N2, NJ, PJ
DOUBLE PRECISION C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL IDAMAX, DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1. Since z is the concatenation of
* two normalized vectors, norm2(z) = sqrt(2).
*
T = ONE / SQRT( TWO )
CALL DSCAL( N, T, Z, 1 )
*
* RHO = ABS( norm(z)**2 * RHO )
*
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 10 I = N1P1, N
INDXQ( I ) = INDXQ( I ) + N1
10 CONTINUE
*
* re-integrate the deflated parts from the last pass
*
DO 20 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
20 CONTINUE
CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )
DO 30 I = 1, N
INDX( I ) = INDXQ( INDXC( I ) )
30 CONTINUE
*
* Calculate the allowable deflation tolerance
*
IMAX = IDAMAX( N, Z, 1 )
JMAX = IDAMAX( N, D, 1 )
EPS = DLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* except to reorganize Q so that its columns correspond with the
* elements in D.
*
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
IQ2 = 1
DO 40 J = 1, N
I = INDX( J )
CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )
DLAMDA( J ) = D( I )
IQ2 = IQ2 + N
40 CONTINUE
CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ )
CALL DCOPY( N, DLAMDA, 1, D, 1 )
GO TO 190
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
DO 50 I = 1, N1
COLTYP( I ) = 1
50 CONTINUE
DO 60 I = N1P1, N
COLTYP( I ) = 3
60 CONTINUE
*
*
K = 0
K2 = N + 1
DO 70 J = 1, N
NJ = INDX( J )
IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
COLTYP( NJ ) = 4
INDXP( K2 ) = NJ
IF( J.EQ.N )
$ GO TO 100
ELSE
PJ = NJ
GO TO 80
END IF
70 CONTINUE
80 CONTINUE
J = J + 1
NJ = INDX( J )
IF( J.GT.N )
$ GO TO 100
IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
COLTYP( NJ ) = 4
INDXP( K2 ) = NJ
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( PJ )
C = Z( NJ )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = DLAPY2( C, S )
T = D( NJ ) - D( PJ )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( NJ ) = TAU
Z( PJ ) = ZERO
IF( COLTYP( NJ ).NE.COLTYP( PJ ) )
$ COLTYP( NJ ) = 2
COLTYP( PJ ) = 4
CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )
T = D( PJ )*C**2 + D( NJ )*S**2
D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2
D( PJ ) = T
K2 = K2 - 1
I = 1
90 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = PJ
I = I + 1
GO TO 90
ELSE
INDXP( K2+I-1 ) = PJ
END IF
ELSE
INDXP( K2+I-1 ) = PJ
END IF
PJ = NJ
ELSE
K = K + 1
DLAMDA( K ) = D( PJ )
W( K ) = Z( PJ )
INDXP( K ) = PJ
PJ = NJ
END IF
END IF
GO TO 80
100 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
DLAMDA( K ) = D( PJ )
W( K ) = Z( PJ )
INDXP( K ) = PJ
*
* Count up the total number of the various types of columns, then
* form a permutation which positions the four column types into
* four uniform groups (although one or more of these groups may be
* empty).
*
DO 110 J = 1, 4
CTOT( J ) = 0
110 CONTINUE
DO 120 J = 1, N
CT = COLTYP( J )
CTOT( CT ) = CTOT( CT ) + 1
120 CONTINUE
*
* PSM(*) = Position in SubMatrix (of types 1 through 4)
*
PSM( 1 ) = 1
PSM( 2 ) = 1 + CTOT( 1 )
PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
K = N - CTOT( 4 )
*
* Fill out the INDXC array so that the permutation which it induces
* will place all type-1 columns first, all type-2 columns next,
* then all type-3's, and finally all type-4's.
*
DO 130 J = 1, N
JS = INDXP( J )
CT = COLTYP( JS )
INDX( PSM( CT ) ) = JS
INDXC( PSM( CT ) ) = J
PSM( CT ) = PSM( CT ) + 1
130 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
I = 1
IQ1 = 1
IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1
DO 140 J = 1, CTOT( 1 )
JS = INDX( I )
CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ1 = IQ1 + N1
140 CONTINUE
*
DO 150 J = 1, CTOT( 2 )
JS = INDX( I )
CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ1 = IQ1 + N1
IQ2 = IQ2 + N2
150 CONTINUE
*
DO 160 J = 1, CTOT( 3 )
JS = INDX( I )
CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ2 = IQ2 + N2
160 CONTINUE
*
IQ1 = IQ2
DO 170 J = 1, CTOT( 4 )
JS = INDX( I )
CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )
IQ2 = IQ2 + N
Z( I ) = D( JS )
I = I + 1
170 CONTINUE
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, Q( 1, K+1 ), LDQ )
CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )
*
* Copy CTOT into COLTYP for referencing in DLAED3.
*
DO 180 J = 1, 4
COLTYP( J ) = CTOT( J )
180 CONTINUE
*
190 CONTINUE
RETURN
*
* End of DLAED2
*
END
SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
$ CTOT, W, S, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, N, N1
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER CTOT( * ), INDX( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ S( * ), W( * )
* ..
*
* Purpose
* =======
*
* DLAED3 finds the roots of the secular equation, as defined by the
* values in D, W, and RHO, between 1 and K. It makes the
* appropriate calls to DLAED4 and then updates the eigenvectors by
* multiplying the matrix of eigenvectors of the pair of eigensystems
* being combined by the matrix of eigenvectors of the K-by-K system
* which is solved here.
*
* This code makes very mild assumptions about floating point
* arithmetic. It will work on machines with a guard digit in
* add/subtract, or on those binary machines without guard digits
* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
* It could conceivably fail on hexadecimal or decimal machines
* without guard digits, but we know of none.
*
* Arguments
* =========
*
* K (input) INTEGER
* The number of terms in the rational function to be solved by
* DLAED4. K >= 0.
*
* N (input) INTEGER
* The number of rows and columns in the Q matrix.
* N >= K (deflation may result in N>K).
*
* N1 (input) INTEGER
* The location of the last eigenvalue in the leading submatrix.
* min(1,N) <= N1 <= N/2.
*
* D (output) DOUBLE PRECISION array, dimension (N)
* D(I) contains the updated eigenvalues for
* 1 <= I <= K.
*
* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
* Initially the first K columns are used as workspace.
* On output the columns 1 to K contain
* the updated eigenvectors.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* RHO (input) DOUBLE PRECISION
* The value of the parameter in the rank one update equation.
* RHO >= 0 required.
*
* DLAMDA (input/output) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation. May be changed on output by
* having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
* Cray-2, or Cray C-90, as described above.
*
* Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N)
* The first K columns of this matrix contain the non-deflated
* eigenvectors for the split problem.
*
* INDX (input) INTEGER array, dimension (N)
* The permutation used to arrange the columns of the deflated
* Q matrix into three groups (see DLAED2).
* The rows of the eigenvectors found by DLAED4 must be likewise
* permuted before the matrix multiply can take place.
*
* CTOT (input) INTEGER array, dimension (4)
* A count of the total number of the various types of columns
* in Q, as described in INDX. The fourth column type is any
* column which has been deflated.
*
* W (input/output) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating vector. Destroyed on
* output.
*
* S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K
* Will contain the eigenvectors of the repaired matrix which
* will be multiplied by the previously accumulated eigenvectors
* to update the system.
*
* LDS (input) INTEGER
* The leading dimension of S. LDS >= max(1,K).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
* Modified by Francoise Tisseur, University of Tennessee.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, II, IQ2, J, N12, N2, N23
DOUBLE PRECISION TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2
EXTERNAL DLAMC3, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( K.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.K ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED3', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
* which on any of these machines zeros out the bottommost
* bit of DLAMDA(I) if it is 1; this makes the subsequent
* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DLAMDA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DLAMDA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 10 I = 1, K
DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = 1, K
CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 )
$ GO TO 120
20 CONTINUE
*
IF( K.EQ.1 )
$ GO TO 110
IF( K.EQ.2 ) THEN
DO 30 J = 1, K
W( 1 ) = Q( 1, J )
W( 2 ) = Q( 2, J )
II = INDX( 1 )
Q( 1, J ) = W( II )
II = INDX( 2 )
Q( 2, J ) = W( II )
30 CONTINUE
GO TO 110
END IF
*
* Compute updated W.
*
CALL DCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL DCOPY( K, Q, LDQ+1, W, 1 )
DO 60 J = 1, K
DO 40 I = 1, J - 1
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
40 CONTINUE
DO 50 I = J + 1, K
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
50 CONTINUE
60 CONTINUE
DO 70 I = 1, K
W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )
70 CONTINUE
*
* Compute eigenvectors of the modified rank-1 modification.
*
DO 100 J = 1, K
DO 80 I = 1, K
S( I ) = W( I ) / Q( I, J )
80 CONTINUE
TEMP = DNRM2( K, S, 1 )
DO 90 I = 1, K
II = INDX( I )
Q( I, J ) = S( II ) / TEMP
90 CONTINUE
100 CONTINUE
*
* Compute the updated eigenvectors.
*
110 CONTINUE
*
N2 = N - N1
N12 = CTOT( 1 ) + CTOT( 2 )
N23 = CTOT( 2 ) + CTOT( 3 )
*
CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
IQ2 = N1*N12 + 1
IF( N23.NE.0 ) THEN
CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
$ ZERO, Q( N1+1, 1 ), LDQ )
ELSE
CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
END IF
*
CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 )
IF( N12.NE.0 ) THEN
CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
$ LDQ )
ELSE
CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
END IF
*
*
120 CONTINUE
RETURN
*
* End of DLAED3
*
END
SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER DTRD1, DTRD2, N1, N2
* ..
* .. Array Arguments ..
INTEGER INDEX( * )
DOUBLE PRECISION A( * )
* ..
*
* Purpose
* =======
*
* DLAMRG will create a permutation list which will merge the elements
* of A (which is composed of two independently sorted sets) into a
* single set which is sorted in ascending order.
*
* Arguments
* =========
*
* N1 (input) INTEGER
* N2 (input) INTEGER
* These arguements contain the respective lengths of the two
* sorted lists to be merged.
*
* A (input) DOUBLE PRECISION array, dimension (N1+N2)
* The first N1 elements of A contain a list of numbers which
* are sorted in either ascending or descending order. Likewise
* for the final N2 elements.
*
* DTRD1 (input) INTEGER
* DTRD2 (input) INTEGER
* These are the strides to be taken through the array A.
* Allowable strides are 1 and -1. They indicate whether a
* subset of A is sorted in ascending (DTRDx = 1) or descending
* (DTRDx = -1) order.
*
* INDEX (output) INTEGER array, dimension (N1+N2)
* On exit this array will contain a permutation such that
* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be
* sorted in ascending order.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IND1, IND2, N1SV, N2SV
* ..
* .. Executable Statements ..
*
N1SV = N1
N2SV = N2
IF( DTRD1.GT.0 ) THEN
IND1 = 1
ELSE
IND1 = N1
END IF
IF( DTRD2.GT.0 ) THEN
IND2 = 1 + N1
ELSE
IND2 = N1 + N2
END IF
I = 1
* while ( (N1SV > 0) & (N2SV > 0) )
10 CONTINUE
IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN
IF( A( IND1 ).LE.A( IND2 ) ) THEN
INDEX( I ) = IND1
I = I + 1
IND1 = IND1 + DTRD1
N1SV = N1SV - 1
ELSE
INDEX( I ) = IND2
I = I + 1
IND2 = IND2 + DTRD2
N2SV = N2SV - 1
END IF
GO TO 10
END IF
* end while
IF( N1SV.EQ.0 ) THEN
DO 20 N1SV = 1, N2SV
INDEX( I ) = IND2
I = I + 1
IND2 = IND2 + DTRD2
20 CONTINUE
ELSE
* N2SV .EQ. 0
DO 30 N2SV = 1, N1SV
INDEX( I ) = IND1
I = I + 1
IND1 = IND1 + DTRD1
30 CONTINUE
END IF
*
RETURN
*
* End of DLAMRG
*
END
SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )
*
* -- LAPACK routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, INFO, N, TLVLS
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
$ PRMPTR( * ), QPTR( * )
DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
* ..
*
* Purpose
* =======
*
* DLAEDA computes the Z vector corresponding to the merge step in the
* CURLVLth step of the merge process with TLVLS steps for the CURPBMth
* problem.
*
* Arguments
* =========
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* TLVLS (input) INTEGER
* The total number of merging levels in the overall divide and
* conquer tree.
*
* CURLVL (input) INTEGER
* The current level in the overall merge routine,
* 0 <= curlvl <= tlvls.
*
* CURPBM (input) INTEGER
* The current problem in the current level in the overall
* merge routine (counting from upper left to lower right).
*
* PRMPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in PERM a
* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
* indicates the size of the permutation and incidentally the
* size of the full, non-deflated problem.
*
* PERM (input) INTEGER array, dimension (N lg N)
* Contains the permutations (from deflation and sorting) to be
* applied to each eigenblock.
*
* GIVPTR (input) INTEGER array, dimension (N lg N)
* Contains a list of pointers which indicate where in GIVCOL a
* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
* indicates the number of Givens rotations.
*
* GIVCOL (input) INTEGER array, dimension (2, N lg N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* Q (input) DOUBLE PRECISION array, dimension (N**2)
* Contains the square eigenblocks from previous levels, the
* starting positions for blocks are given by QPTR.
*
* QPTR (input) INTEGER array, dimension (N+2)
* Contains a list of pointers which indicate where in Q an
* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates
* the size of the block.
*
* Z (output) DOUBLE PRECISION array, dimension (N)
* On output this vector contains the updating vector (the last
* row of the first sub-eigenvector matrix and the first row of
* the second sub-eigenvector matrix).
*
* ZTEMP (workspace) DOUBLE PRECISION array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
$ PTR, ZPTR1
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV, DROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, INT, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAEDA', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine location of first number in second half.
*
MID = N / 2 + 1
*
* Gather last/first rows of appropriate eigenblocks into center of Z
*
PTR = 1
*
* Determine location of lowest level subproblem in the full storage
* scheme
*
CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1
*
* Determine size of these matrices. We add HALF to the value of
* the SQRT in case the machine underestimates one of these square
* roots.
*
BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )
DO 10 K = 1, MID - BSIZ1 - 1
Z( K ) = ZERO
10 CONTINUE
CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,
$ Z( MID-BSIZ1 ), 1 )
CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )
DO 20 K = MID + BSIZ2, N
Z( K ) = ZERO
20 CONTINUE
*
* Loop through remaining levels 1 -> CURLVL applying the Givens
* rotations and permutation and then multiplying the center matrices
* against the current Z.
*
PTR = 2**TLVLS + 1
DO 70 K = 1, CURLVL - 1
CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1
PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
ZPTR1 = MID - PSIZ1
*
* Apply Givens at CURR and CURR+1
*
DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1
CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,
$ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),
$ GIVNUM( 2, I ) )
30 CONTINUE
DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1
CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,
$ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),
$ GIVNUM( 2, I ) )
40 CONTINUE
PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
DO 50 I = 0, PSIZ1 - 1
ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )
50 CONTINUE
DO 60 I = 0, PSIZ2 - 1
ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )
60 CONTINUE
*
* Multiply Blocks at CURR and CURR+1
*
* Determine size of these matrices. We add HALF to the value of
* the SQRT in case the machine underestimates one of these
* square roots.
*
BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+
$ 1 ) ) ) )
IF( BSIZ1.GT.0 ) THEN
CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),
$ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )
END IF
CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ),
$ 1 )
IF( BSIZ2.GT.0 ) THEN
CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),
$ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )
END IF
CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,
$ Z( MID+BSIZ2 ), 1 )
*
PTR = PTR + 2**( TLVLS-K )
70 CONTINUE
*
RETURN
*
* End of DLAEDA
*
END
SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,
$ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,
$ GIVCOL, GIVNUM, INDXP, INDX, INFO )
*
* -- LAPACK routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2010
*
* .. Scalar Arguments ..
INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
$ QSIZ
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
$ INDXQ( * ), PERM( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ),
$ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
* ..
*
* Purpose
* =======
*
* DLAED8 merges the two sets of eigenvalues together into a single
* sorted set. Then it tries to deflate the size of the problem.
* There are two ways in which deflation can occur: when two or more
* eigenvalues are close together or if there is a tiny element in the
* Z vector. For each such occurrence the order of the related secular
* equation problem is reduced by one.
*
* Arguments
* =========
*
* ICOMPQ (input) INTEGER
* = 0: Compute eigenvalues only.
* = 1: Compute eigenvectors of original dense symmetric matrix
* also. On entry, Q contains the orthogonal matrix used
* to reduce the original matrix to tridiagonal form.
*
* K (output) INTEGER
* The number of non-deflated eigenvalues, and the order of the
* related secular equation.
*
* N (input) INTEGER
* The dimension of the symmetric tridiagonal matrix. N >= 0.
*
* QSIZ (input) INTEGER
* The dimension of the orthogonal matrix used to reduce
* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the eigenvalues of the two submatrices to be
* combined. On exit, the trailing (N-K) updated eigenvalues
* (those which were deflated) sorted into increasing order.
*
* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
* If ICOMPQ = 0, Q is not referenced. Otherwise,
* on entry, Q contains the eigenvectors of the partially solved
* system which has been previously updated in matrix
* multiplies with other partially solved eigensystems.
* On exit, Q contains the trailing (N-K) updated eigenvectors
* (those which were deflated) in its last N-K columns.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* INDXQ (input) INTEGER array, dimension (N)
* The permutation which separately sorts the two sub-problems
* in D into ascending order. Note that elements in the second
* half of this permutation must first have CUTPNT added to
* their values in order to be accurate.
*
* RHO (input/output) DOUBLE PRECISION
* On entry, the off-diagonal element associated with the rank-1
* cut which originally split the two submatrices which are now
* being recombined.
* On exit, RHO has been modified to the value required by
* DLAED3.
*
* CUTPNT (input) INTEGER
* The location of the last eigenvalue in the leading
* sub-matrix. min(1,N) <= CUTPNT <= N.
*
* Z (input) DOUBLE PRECISION array, dimension (N)
* On entry, Z contains the updating vector (the last row of
* the first sub-eigenvector matrix and the first row of the
* second sub-eigenvector matrix).
* On exit, the contents of Z are destroyed by the updating
* process.
*
* DLAMDA (output) DOUBLE PRECISION array, dimension (N)
* A copy of the first K eigenvalues which will be used by
* DLAED3 to form the secular equation.
*
* Q2 (output) DOUBLE PRECISION array, dimension (LDQ2,N)
* If ICOMPQ = 0, Q2 is not referenced. Otherwise,
* a copy of the first K eigenvectors which will be used by
* DLAED7 in a matrix multiply (DGEMM) to update the new
* eigenvectors.
*
* LDQ2 (input) INTEGER
* The leading dimension of the array Q2. LDQ2 >= max(1,N).
*
* W (output) DOUBLE PRECISION array, dimension (N)
* The first k values of the final deflation-altered z-vector and
* will be passed to DLAED3.
*
* PERM (output) INTEGER array, dimension (N)
* The permutations (from deflation and sorting) to be applied
* to each eigenblock.
*
* GIVPTR (output) INTEGER
* The number of Givens rotations which took place in this
* subproblem.
*
* GIVCOL (output) INTEGER array, dimension (2, N)
* Each pair of numbers indicates a pair of columns to take place
* in a Givens rotation.
*
* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)
* Each number indicates the S value to be used in the
* corresponding Givens rotation.
*
* INDXP (workspace) INTEGER array, dimension (N)
* The permutation used to place deflated values of D at the end
* of the array. INDXP(1:K) points to the nondeflated D-values
* and INDXP(K+1:N) points to the deflated eigenvalues.
*
* INDX (workspace) INTEGER array, dimension (N)
* The permutation used to sort the contents of D into ascending
* order.
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, EIGHT = 8.0D0 )
* ..
* .. Local Scalars ..
*
INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
DOUBLE PRECISION C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL IDAMAX, DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
INFO = -10
ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED8', -INFO )
RETURN
END IF
*
* Need to initialize GIVPTR to O here in case of quick exit
* to prevent an unspecified code behavior (usually sigfault)
* when IWORK array on entry to *stedc is not zeroed
* (or at least some IWORK entries which used in *laed7 for GIVPTR).
*
GIVPTR = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N1 = CUTPNT
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1
*
T = ONE / SQRT( TWO )
DO 10 J = 1, N
INDX( J ) = J
10 CONTINUE
CALL DSCAL( N, T, Z, 1 )
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 20 I = CUTPNT + 1, N
INDXQ( I ) = INDXQ( I ) + CUTPNT
20 CONTINUE
DO 30 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
W( I ) = Z( INDXQ( I ) )
30 CONTINUE
I = 1
J = CUTPNT + 1
CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
DO 40 I = 1, N
D( I ) = DLAMDA( INDX( I ) )
Z( I ) = W( INDX( I ) )
40 CONTINUE
*
* Calculate the allowable deflation tolerence
*
IMAX = IDAMAX( N, Z, 1 )
JMAX = IDAMAX( N, D, 1 )
EPS = DLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*ABS( D( JMAX ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* except to reorganize Q so that its columns correspond with the
* elements in D.
*
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
IF( ICOMPQ.EQ.0 ) THEN
DO 50 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
50 CONTINUE
ELSE
DO 60 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
60 CONTINUE
CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ),
$ LDQ )
END IF
RETURN
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
K = 0
K2 = N + 1
DO 70 J = 1, N
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
IF( J.EQ.N )
$ GO TO 110
ELSE
JLAM = J
GO TO 80
END IF
70 CONTINUE
80 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 100
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( JLAM )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = DLAPY2( C, S )
T = D( J ) - D( JLAM )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( J ) = TAU
Z( JLAM ) = ZERO
*
* Record the appropriate Givens rotation
*
GIVPTR = GIVPTR + 1
GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
GIVNUM( 1, GIVPTR ) = C
GIVNUM( 2, GIVPTR ) = S
IF( ICOMPQ.EQ.1 ) THEN
CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
$ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
END IF
T = D( JLAM )*C*C + D( J )*S*S
D( J ) = D( JLAM )*S*S + D( J )*C*C
D( JLAM ) = T
K2 = K2 - 1
I = 1
90 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = JLAM
I = I + 1
GO TO 90
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
JLAM = J
ELSE
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
JLAM = J
END IF
END IF
GO TO 80
100 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
*
110 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
IF( ICOMPQ.EQ.0 ) THEN
DO 120 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
120 CONTINUE
ELSE
DO 130 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
130 CONTINUE
END IF
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
IF( K.LT.N ) THEN
IF( ICOMPQ.EQ.0 ) THEN
CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
ELSE
CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,
$ Q( 1, K+1 ), LDQ )
END IF
END IF
*
RETURN
*
* End of DLAED8
*
END
SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,
$ S, LDS, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
$ W( * )
* ..
*
* Purpose
* =======
*
* DLAED9 finds the roots of the secular equation, as defined by the
* values in D, Z, and RHO, between KSTART and KSTOP. It makes the
* appropriate calls to DLAED4 and then stores the new matrix of
* eigenvectors for use in calculating the next level of Z vectors.
*
* Arguments
* =========
*
* K (input) INTEGER
* The number of terms in the rational function to be solved by
* DLAED4. K >= 0.
*
* KSTART (input) INTEGER
* KSTOP (input) INTEGER
* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
* are to be computed. 1 <= KSTART <= KSTOP <= K.
*
* N (input) INTEGER
* The number of rows and columns in the Q matrix.
* N >= K (delation may result in N > K).
*
* D (output) DOUBLE PRECISION array, dimension (N)
* D(I) contains the updated eigenvalues
* for KSTART <= I <= KSTOP.
*
* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N)
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max( 1, N ).
*
* RHO (input) DOUBLE PRECISION
* The value of the parameter in the rank one update equation.
* RHO >= 0 required.
*
* DLAMDA (input) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the old roots
* of the deflated updating problem. These are the poles
* of the secular equation.
*
* W (input) DOUBLE PRECISION array, dimension (K)
* The first K elements of this array contain the components
* of the deflation-adjusted updating vector.
*
* S (output) DOUBLE PRECISION array, dimension (LDS, K)
* Will contain the eigenvectors of the repaired matrix which
* will be stored for subsequent Z vector calculation and
* multiplied by the previously accumulated eigenvectors
* to update the system.
*
* LDS (input) INTEGER
* The leading dimension of S. LDS >= max( 1, K ).
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = 1, an eigenvalue did not converge
*
* Further Details
* ===============
*
* Based on contributions by
* Jeff Rutter, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2
EXTERNAL DLAMC3, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAED4, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( K.LT.0 ) THEN
INFO = -1
ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN
INFO = -2
ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) )
$ THEN
INFO = -3
ELSE IF( N.LT.K ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN
INFO = -7
ELSE IF( LDS.LT.MAX( 1, K ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAED9', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
* which on any of these machines zeros out the bottommost
* bit of DLAMDA(I) if it is 1; this makes the subsequent
* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DLAMDA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DLAMDA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 10 I = 1, N
DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = KSTART, KSTOP
CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 )
$ GO TO 120
20 CONTINUE
*
IF( K.EQ.1 .OR. K.EQ.2 ) THEN
DO 40 I = 1, K
DO 30 J = 1, K
S( J, I ) = Q( J, I )
30 CONTINUE
40 CONTINUE
GO TO 120
END IF
*
* Compute updated W.
*
CALL DCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL DCOPY( K, Q, LDQ+1, W, 1 )
DO 70 J = 1, K
DO 50 I = 1, J - 1
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
50 CONTINUE
DO 60 I = J + 1, K
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
60 CONTINUE
70 CONTINUE
DO 80 I = 1, K
W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )
80 CONTINUE
*
* Compute eigenvectors of the modified rank-1 modification.
*
DO 110 J = 1, K
DO 90 I = 1, K
Q( I, J ) = W( I ) / Q( I, J )
90 CONTINUE
TEMP = DNRM2( K, Q( 1, J ), 1 )
DO 100 I = 1, K
S( I, J ) = Q( I, J ) / TEMP
100 CONTINUE
110 CONTINUE
*
120 CONTINUE
RETURN
*
* End of DLAED9
*
END
SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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 )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILADLR, ILADLC
EXTERNAL LSAME, ILADLR, ILADLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
LASTV = 0
LASTC = 0
IF( TAU.NE.ZERO ) THEN
! Set up variables for scanning V. LASTV begins pointing to the end
! of V.
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
IF( INCV.GT.0 ) THEN
I = 1 + (LASTV-1) * INCV
ELSE
I = 1
END IF
! Look for the last non-zero row in V.
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
LASTV = LASTV - 1
I = I - INCV
END DO
IF( APPLYLEFT ) THEN
! Scan for the last non-zero column in C(1:lastv,:).
LASTC = ILADLC(LASTV, N, C, LDC)
ELSE
! Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILADLR(M, LASTV, C, LDC)
END IF
END IF
! Note that lastc.eq.0 renders the BLAS operations null; no special
! case is needed at this level.
IF( APPLYLEFT ) THEN
*
* Form H * C
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1)
*
CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,
$ ZERO, WORK, 1 )
*
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)'
*
CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
$ V, INCV, ZERO, WORK, 1 )
*
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)'
*
CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* End of DLARF
*
END
INTEGER FUNCTION ILADLR( M, N, A, LDA )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2.2) --
*
* -- June 2010 --
*
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* ILADLR scans A for its last non-zero row.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of the matrix A.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The m by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( M.EQ.0 ) THEN
ILADLR = M
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILADLR = M
ELSE
* Scan up each column tracking the last zero row seen.
ILADLR = 0
DO J = 1, N
DO I = M, 1, -1
IF( A(I, J).NE.ZERO ) EXIT
END DO
ILADLR = MAX( ILADLR, I )
END DO
END IF
RETURN
END
INTEGER FUNCTION ILADLC( M, N, A, LDA )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.2.2) --
*
* -- June 2010 --
*
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* ILADLC scans A for its last non-zero column.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix A.
*
* N (input) INTEGER
* The number of columns of the matrix A.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The m by n matrix A.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( N.EQ.0 ) THEN
ILADLC = N
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILADLC = N
ELSE
* Now scan each column from the end, returning with the first non-zero.
DO ILADLC = N, 1, -1
DO I = 1, M
IF( A(I, ILADLC).NE.ZERO ) RETURN
END DO
END DO
END IF
RETURN
END
SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, TAU, TTYPE, G )
*
* -- LAPACK routine (version 3.2) --
*
* -- Contributed by Osni Marques of the Lawrence Berkeley National --
* -- Laboratory and Beresford Parlett of the Univ. of California at --
* -- Berkeley --
* -- November 2008 --
*
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER I0, N0, N0IN, PP, TTYPE
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLASQ4 computes an approximation TAU to the smallest eigenvalue
* using values of d from the previous transform.
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* NOIN (input) INTEGER
* The value of N0 at start of EIGTEST.
*
* DMIN (input) DOUBLE PRECISION
* Minimum value of d.
*
* DMIN1 (input) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (input) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (input) DOUBLE PRECISION
* d(N)
*
* DN1 (input) DOUBLE PRECISION
* d(N-1)
*
* DN2 (input) DOUBLE PRECISION
* d(N-2)
*
* TAU (output) DOUBLE PRECISION
* This is the shift.
*
* TTYPE (output) INTEGER
* Shift type.
*
* G (input/output) REAL
* G is passed as an argument in order to save its value between
* calls to DLASQ4.
*
* Further Details
* ===============
* CNST1 = 9/16
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CNST1, CNST2, CNST3
PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0,
$ CNST3 = 1.050D0 )
DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0,
$ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
INTEGER I4, NN, NP
DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* A negative DMIN forces the shift to take that absolute value
* TTYPE records the type of shift.
*
IF( DMIN.LE.ZERO ) THEN
TAU = -DMIN
TTYPE = -1
RETURN
END IF
*
NN = 4*N0 + PP
IF( N0IN.EQ.N0 ) THEN
*
* No eigenvalues deflated.
*
IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
*
B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
A2 = Z( NN-7 ) + Z( NN-5 )
*
* Cases 2 and 3.
*
IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
GAP2 = DMIN2 - A2 - DMIN2*QURTR
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
GAP1 = A2 - DN - ( B2 / GAP2 )*B2
ELSE
GAP1 = A2 - DN - ( B1+B2 )
END IF
IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
TTYPE = -2
ELSE
S = ZERO
IF( DN.GT.B1 )
$ S = DN - B1
IF( A2.GT.( B1+B2 ) )
$ S = MIN( S, A2-( B1+B2 ) )
S = MAX( S, THIRD*DMIN )
TTYPE = -3
END IF
ELSE
*
* Case 4.
*
TTYPE = -4
S = QURTR*DMIN
IF( DMIN.EQ.DN ) THEN
GAM = DN
A2 = ZERO
IF( Z( NN-5 ) .GT. Z( NN-7 ) )
$ RETURN
B2 = Z( NN-5 ) / Z( NN-7 )
NP = NN - 9
ELSE
NP = NN - 2*PP
B2 = Z( NP-2 )
GAM = DN1
IF( Z( NP-4 ) .GT. Z( NP-2 ) )
$ RETURN
A2 = Z( NP-4 ) / Z( NP-2 )
IF( Z( NN-9 ) .GT. Z( NN-11 ) )
$ RETURN
B2 = Z( NN-9 ) / Z( NN-11 )
NP = NN - 13
END IF
*
* Approximate contribution to norm squared from I < NN-1.
*
A2 = A2 + B2
DO 10 I4 = NP, 4*I0 - 1 + PP, -4
IF( B2.EQ.ZERO )
$ GO TO 20
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 20
10 CONTINUE
20 CONTINUE
A2 = CNST3*A2
*
* Rayleigh quotient residual bound.
*
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
END IF
ELSE IF( DMIN.EQ.DN2 ) THEN
*
* Case 5.
*
TTYPE = -5
S = QURTR*DMIN
*
* Compute contribution to norm squared from I > NN-2.
*
NP = NN - 2*PP
B1 = Z( NP-2 )
B2 = Z( NP-6 )
GAM = DN2
IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
$ RETURN
A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
*
* Approximate contribution to norm squared from I < NN-2.
*
IF( N0-I0.GT.2 ) THEN
B2 = Z( NN-13 ) / Z( NN-15 )
A2 = A2 + B2
DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
IF( B2.EQ.ZERO )
$ GO TO 40
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 40
30 CONTINUE
40 CONTINUE
A2 = CNST3*A2
END IF
*
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
ELSE
*
* Case 6, no information to guide us.
*
IF( TTYPE.EQ.-6 ) THEN
G = G + THIRD*( ONE-G )
ELSE IF( TTYPE.EQ.-18 ) THEN
G = QURTR*THIRD
ELSE
G = QURTR
END IF
S = G*DMIN
TTYPE = -6
END IF
*
ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
*
* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
*
IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
*
* Cases 7 and 8.
*
TTYPE = -7
S = THIRD*DMIN1
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 60
DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
A2 = B1
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*MAX( B1, A2 ).LT.B2 )
$ GO TO 60
50 CONTINUE
60 CONTINUE
B2 = SQRT( CNST3*B2 )
A2 = DMIN1 / ( ONE+B2**2 )
GAP2 = HALF*DMIN2 - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
S = MAX( S, A2*( ONE-CNST2*B2 ) )
TTYPE = -8
END IF
ELSE
*
* Case 9.
*
S = QURTR*DMIN1
IF( DMIN1.EQ.DN1 )
$ S = HALF*DMIN1
TTYPE = -9
END IF
*
ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
*
* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
*
* Cases 10 and 11.
*
IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
TTYPE = -10
S = THIRD*DMIN2
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 80
DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*B1.LT.B2 )
$ GO TO 80
70 CONTINUE
80 CONTINUE
B2 = SQRT( CNST3*B2 )
A2 = DMIN2 / ( ONE+B2**2 )
GAP2 = Z( NN-7 ) + Z( NN-9 ) -
$ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
S = MAX( S, A2*( ONE-CNST2*B2 ) )
END IF
ELSE
S = QURTR*DMIN2
TTYPE = -11
END IF
ELSE IF( N0IN.GT.( N0+2 ) ) THEN
*
* Case 12, more than two eigenvalues deflated. No information.
*
S = ZERO
TTYPE = -12
END IF
*
TAU = S
RETURN
*
* End of DLASQ4
*
END
SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2, IEEE )
*
* -- LAPACK routine (version 3.2) --
*
* -- Contributed by Osni Marques of the Lawrence Berkeley National --
* -- Laboratory and Beresford Parlett of the Univ. of California at --
* -- Berkeley --
* -- November 2008 --
*
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER I0, N0, PP
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLASQ5 computes one dqds transform in ping-pong form, one
* version for IEEE machines another for non IEEE machines.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
* an extra argument.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* TAU (input) DOUBLE PRECISION
* This is the shift.
*
* DMIN (output) DOUBLE PRECISION
* Minimum value of d.
*
* DMIN1 (output) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (output) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (output) DOUBLE PRECISION
* d(N0), the last value of d.
*
* DNM1 (output) DOUBLE PRECISION
* d(N0-1).
*
* DNM2 (output) DOUBLE PRECISION
* d(N0-2).
*
* IEEE (input) LOGICAL
* Flag for IEEE or non IEEE arithmetic.
*
* =====================================================================
*
* .. Parameter ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER J4, J4P2
DOUBLE PRECISION D, EMIN, TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( ( N0-I0-1 ).LE.0 )
$ RETURN
*
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 ) - TAU
DMIN = D
DMIN1 = -Z( J4 )
*
IF( IEEE ) THEN
*
* Code for IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
TEMP = Z( J4+1 ) / Z( J4-2 )
D = D*TEMP - TAU
DMIN = MIN( DMIN, D )
Z( J4 ) = Z( J4-1 )*TEMP
EMIN = MIN( Z( J4 ), EMIN )
10 CONTINUE
ELSE
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
TEMP = Z( J4+2 ) / Z( J4-3 )
D = D*TEMP - TAU
DMIN = MIN( DMIN, D )
Z( J4-1 ) = Z( J4 )*TEMP
EMIN = MIN( Z( J4-1 ), EMIN )
20 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DN )
*
ELSE
*
* Code for non IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 30 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
30 CONTINUE
ELSE
DO 40 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
40 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( DNM2.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( DNM1.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DN )
*
END IF
*
Z( J4+2 ) = DN
Z( 4*N0-PP ) = EMIN
RETURN
*
* End of DLASQ5
*
END
SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2 )
*
* -- LAPACK routine (version 3.2) --
*
* -- Contributed by Osni Marques of the Lawrence Berkeley National --
* -- Laboratory and Beresford Parlett of the Univ. of California at --
* -- Berkeley --
* -- November 2008 --
*
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER I0, N0, PP
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLASQ6 computes one dqd (shift equal to zero) transform in
* ping-pong form, with protection against underflow and overflow.
*
* Arguments
* =========
*
* I0 (input) INTEGER
* First index.
*
* N0 (input) INTEGER
* Last index.
*
* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
* an extra argument.
*
* PP (input) INTEGER
* PP=0 for ping, PP=1 for pong.
*
* DMIN (output) DOUBLE PRECISION
* Minimum value of d.
*
* DMIN1 (output) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ).
*
* DMIN2 (output) DOUBLE PRECISION
* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
* DN (output) DOUBLE PRECISION
* d(N0), the last value of d.
*
* DNM1 (output) DOUBLE PRECISION
* d(N0-1).
*
* DNM2 (output) DOUBLE PRECISION
* d(N0-2).
*
* =====================================================================
*
* .. Parameter ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER J4, J4P2
DOUBLE PRECISION D, EMIN, SAFMIN, TEMP
* ..
* .. External Function ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( ( N0-I0-1 ).LE.0 )
$ RETURN
*
SAFMIN = DLAMCH( 'Safe minimum' )
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 )
DMIN = D
*
IF( PP.EQ.0 ) THEN
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
D = Z( J4+1 )
DMIN = D
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN
TEMP = Z( J4+1 ) / Z( J4-2 )
Z( J4 ) = Z( J4-1 )*TEMP
D = D*TEMP
ELSE
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
10 CONTINUE
ELSE
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( Z( J4-3 ).EQ.ZERO ) THEN
Z( J4-1 ) = ZERO
D = Z( J4+2 )
DMIN = D
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND.
$ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN
TEMP = Z( J4+2 ) / Z( J4-3 )
Z( J4-1 ) = Z( J4 )*TEMP
D = D*TEMP
ELSE
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) )
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
20 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
DNM1 = Z( J4P2+2 )
DMIN = DNM1
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
TEMP = Z( J4P2+2 ) / Z( J4-2 )
Z( J4 ) = Z( J4P2 )*TEMP
DNM1 = DNM2*TEMP
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
DN = Z( J4P2+2 )
DMIN = DN
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
TEMP = Z( J4P2+2 ) / Z( J4-2 )
Z( J4 ) = Z( J4P2 )*TEMP
DN = DNM1*TEMP
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, DN )
*
Z( J4+2 ) = DN
Z( 4*N0-PP ) = EMIN
RETURN
*
* End of DLASQ6
*
END
SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER I, INFO, N
DOUBLE PRECISION DLAM, RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DELTA( * ), Z( * )
* ..
*
* Purpose
* =======
*
* This subroutine computes the I-th updated eigenvalue of a symmetric
* rank-one modification to a diagonal matrix whose elements are
* given in the array d, and that
*
* D(i) < D(j) for i < j
*
* and that RHO > 0. This is arranged by the calling routine, and is
* no loss in generality. The rank-one modified system is thus
*
* diag( D ) + RHO * Z * Z_transpose.
*
* where we assume the Euclidean norm of Z is 1.
*
* The method consists of approximating the rational functions in the
* secular equation by simpler interpolating rational functions.
*
* Arguments
* =========
*
* N (input) INTEGER
* The length of all arrays.
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. 1 <= I <= N.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The original eigenvalues. It is assumed that they are in
* order, D(I) < D(J) for I < J.
*
* Z (input) DOUBLE PRECISION array, dimension (N)
* The components of the updating vector.
*
* DELTA (output) DOUBLE PRECISION array, dimension (N)
* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th
* component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5
* for detail. The vector DELTA contains the information necessary
* to construct the eigenvectors by DLAED3 and DLAED9.
*
* RHO (input) DOUBLE PRECISION
* The scalar in the symmetric updating formula.
*
* DLAM (output) DOUBLE PRECISION
* The computed lambda_I, the I-th updated eigenvalue.
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, the updating process failed.
*
* Internal Parameters
* ===================
*
* Logical variable ORGATI (origin-at-i?) is used for distinguishing
* whether D(i) or D(i+1) is treated as the origin.
*
* ORGATI = .true. origin at i
* ORGATI = .false. origin at i+1
*
* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
* if we are working with THREE poles!
*
* MAXIT is the maximum number of iterations allowed for each
* eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0,
$ TEN = 10.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ORGATI, SWTCH, SWTCH3
INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
DOUBLE PRECISION A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,
$ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,
$ RHOINV, TAU, TEMP, TEMP1, W
* ..
* .. Local Arrays ..
DOUBLE PRECISION ZZ( 3 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLAED5, DLAED6
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Since this routine is called in an inner loop, we do no argument
* checking.
*
* Quick return for N=1 and 2.
*
INFO = 0
IF( N.EQ.1 ) THEN
*
* Presumably, I=1 upon entry
*
DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )
DELTA( 1 ) = ONE
RETURN
END IF
IF( N.EQ.2 ) THEN
CALL DLAED5( I, D, Z, DELTA, RHO, DLAM )
RETURN
END IF
*
* Compute machine epsilon
*
EPS = DLAMCH( 'Epsilon' )
RHOINV = ONE / RHO
*
* The case I = N
*
IF( I.EQ.N ) THEN
*
* Initialize some basic variables
*
II = N - 1
NITER = 1
*
* Calculate initial guess
*
MIDPT = RHO / TWO
*
* If ||Z||_2 is not one, then TEMP should be set to
* RHO * ||Z||_2^2 / TWO
*
DO 10 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
10 CONTINUE
*
PSI = ZERO
DO 20 J = 1, N - 2
PSI = PSI + Z( J )*Z( J ) / DELTA( J )
20 CONTINUE
*
C = RHOINV + PSI
W = C + Z( II )*Z( II ) / DELTA( II ) +
$ Z( N )*Z( N ) / DELTA( N )
*
IF( W.LE.ZERO ) THEN
TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +
$ Z( N )*Z( N ) / RHO
IF( C.LE.TEMP ) THEN
TAU = RHO
ELSE
DEL = D( N ) - D( N-1 )
A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
END IF
*
* It can be proved that
* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
*
DLTLB = MIDPT
DLTUB = RHO
ELSE
DEL = D( N ) - D( N-1 )
A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
*
* It can be proved that
* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
*
DLTLB = ZERO
DLTUB = MIDPT
END IF
*
DO 30 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TAU
30 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 40 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
40 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
DLAM = D( I ) + TAU
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
NITER = NITER + 1
C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
A = ( DELTA( N-1 )+DELTA( N ) )*W -
$ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
B = DELTA( N-1 )*DELTA( N )*W
IF( C.LT.ZERO )
$ C = ABS( C )
IF( C.EQ.ZERO ) THEN
* ETA = B/A
* ETA = RHO - TAU
ETA = DLTUB - TAU
ELSE IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
DO 50 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
50 CONTINUE
*
TAU = TAU + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 60 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
60 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 90 NITER = ITER, MAXIT
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
DLAM = D( I ) + TAU
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
A = ( DELTA( N-1 )+DELTA( N ) )*W -
$ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
B = DELTA( N-1 )*DELTA( N )*W
IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
DO 70 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
70 CONTINUE
*
TAU = TAU + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 80 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
80 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
90 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
DLAM = D( I ) + TAU
GO TO 250
*
* End for the case I = N
*
ELSE
*
* The case for I < N
*
NITER = 1
IP1 = I + 1
*
* Calculate initial guess
*
DEL = D( IP1 ) - D( I )
MIDPT = DEL / TWO
DO 100 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
100 CONTINUE
*
PSI = ZERO
DO 110 J = 1, I - 1
PSI = PSI + Z( J )*Z( J ) / DELTA( J )
110 CONTINUE
*
PHI = ZERO
DO 120 J = N, I + 2, -1
PHI = PHI + Z( J )*Z( J ) / DELTA( J )
120 CONTINUE
C = RHOINV + PSI + PHI
W = C + Z( I )*Z( I ) / DELTA( I ) +
$ Z( IP1 )*Z( IP1 ) / DELTA( IP1 )
*
IF( W.GT.ZERO ) THEN
*
* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
*
* We choose d(i) as origin.
*
ORGATI = .TRUE.
A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
B = Z( I )*Z( I )*DEL
IF( A.GT.ZERO ) THEN
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
ELSE
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
END IF
DLTLB = ZERO
DLTUB = MIDPT
ELSE
*
* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
*
* We choose d(i+1) as origin.
*
ORGATI = .FALSE.
A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
B = Z( IP1 )*Z( IP1 )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
ELSE
TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
END IF
DLTLB = -MIDPT
DLTUB = ZERO
END IF
*
IF( ORGATI ) THEN
DO 130 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TAU
130 CONTINUE
ELSE
DO 140 J = 1, N
DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU
140 CONTINUE
END IF
IF( ORGATI ) THEN
II = I
ELSE
II = I + 1
END IF
IIM1 = II - 1
IIP1 = II + 1
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 150 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
150 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 160 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
160 CONTINUE
*
W = RHOINV + PHI + PSI
*
* W is the value of the secular function with
* its ii-th element removed.
*
SWTCH3 = .FALSE.
IF( ORGATI ) THEN
IF( W.LT.ZERO )
$ SWTCH3 = .TRUE.
ELSE
IF( W.GT.ZERO )
$ SWTCH3 = .TRUE.
END IF
IF( II.EQ.1 .OR. II.EQ.N )
$ SWTCH3 = .FALSE.
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = W + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
NITER = NITER + 1
IF( .NOT.SWTCH3 ) THEN
IF( ORGATI ) THEN
C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*
$ ( Z( I ) / DELTA( I ) )**2
ELSE
C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
$ ( Z( IP1 ) / DELTA( IP1 ) )**2
END IF
A = ( DELTA( I )+DELTA( IP1 ) )*W -
$ DELTA( I )*DELTA( IP1 )*DW
B = DELTA( I )*DELTA( IP1 )*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*
$ ( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*
$ ( DPSI+DPHI )
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
TEMP = RHOINV + PSI + PHI
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
$ ( D( IIM1 )-D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
$ ( ( DPSI-TEMP1 )+DPHI )
ELSE
TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
$ ( D( IIP1 )-D( IIM1 ) )*TEMP1
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
$ ( DPSI+( DPHI-TEMP1 ) )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
ZZ( 2 ) = Z( II )*Z( II )
CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 250
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GE.ZERO )
$ ETA = -W / DW
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
*
PREW = W
*
DO 180 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
180 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 190 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
190 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 200 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
200 CONTINUE
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW
*
SWTCH = .FALSE.
IF( ORGATI ) THEN
IF( -W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
ELSE
IF( W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
END IF
*
TAU = TAU + ETA
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 240 NITER = ITER, MAXIT
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
IF( .NOT.SWTCH3 ) THEN
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
C = W - DELTA( IP1 )*DW -
$ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2
ELSE
C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
$ ( Z( IP1 ) / DELTA( IP1 ) )**2
END IF
ELSE
TEMP = Z( II ) / DELTA( II )
IF( ORGATI ) THEN
DPSI = DPSI + TEMP*TEMP
ELSE
DPHI = DPHI + TEMP*TEMP
END IF
C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI
END IF
A = ( DELTA( I )+DELTA( IP1 ) )*W -
$ DELTA( I )*DELTA( IP1 )*DW
B = DELTA( I )*DELTA( IP1 )*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DELTA( IP1 )*
$ DELTA( IP1 )*( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) +
$ DELTA( I )*DELTA( I )*( DPSI+DPHI )
END IF
ELSE
A = DELTA( I )*DELTA( I )*DPSI +
$ DELTA( IP1 )*DELTA( IP1 )*DPHI
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
TEMP = RHOINV + PSI + PHI
IF( SWTCH ) THEN
C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI
ELSE
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
$ ( D( IIM1 )-D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
$ ( ( DPSI-TEMP1 )+DPHI )
ELSE
TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
$ ( D( IIP1 )-D( IIM1 ) )*TEMP1
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
$ ( DPSI+( DPHI-TEMP1 ) )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
END IF
CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 250
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GE.ZERO )
$ ETA = -W / DW
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
*
DO 210 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
210 CONTINUE
*
TAU = TAU + ETA
PREW = W
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 220 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
220 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 230 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
230 CONTINUE
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
$ SWTCH = .NOT.SWTCH
*
240 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
*
END IF
*
250 CONTINUE
*
RETURN
*
* End of DLAED4
*
END
SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER I
DOUBLE PRECISION DLAM, RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 )
* ..
*
* Purpose
* =======
*
* This subroutine computes the I-th eigenvalue of a symmetric rank-one
* modification of a 2-by-2 diagonal matrix
*
* diag( D ) + RHO * Z * transpose(Z) .
*
* The diagonal elements in the array D are assumed to satisfy
*
* D(i) < D(j) for i < j .
*
* We also assume RHO > 0 and that the Euclidean norm of the vector
* Z is one.
*
* Arguments
* =========
*
* I (input) INTEGER
* The index of the eigenvalue to be computed. I = 1 or I = 2.
*
* D (input) DOUBLE PRECISION array, dimension (2)
* The original eigenvalues. We assume D(1) < D(2).
*
* Z (input) DOUBLE PRECISION array, dimension (2)
* The components of the updating vector.
*
* DELTA (output) DOUBLE PRECISION array, dimension (2)
* The vector DELTA contains the information necessary
* to construct the eigenvectors.
*
* RHO (input) DOUBLE PRECISION
* The scalar in the symmetric updating formula.
*
* DLAM (output) DOUBLE PRECISION
* The computed lambda_I, the I-th updated eigenvalue.
*
* Further Details
* ===============
*
* Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, FOUR
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION B, C, DEL, TAU, TEMP, W
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
DEL = D( 2 ) - D( 1 )
IF( I.EQ.1 ) THEN
W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL
IF( W.GT.ZERO ) THEN
B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 1 )*Z( 1 )*DEL
*
* B > ZERO, always
*
TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
DLAM = D( 1 ) + TAU
DELTA( 1 ) = -Z( 1 ) / TAU
DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
ELSE
B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DEL
IF( B.GT.ZERO ) THEN
TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
ELSE
TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
END IF
DLAM = D( 2 ) + TAU
DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
DELTA( 2 ) = -Z( 2 ) / TAU
END IF
TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
DELTA( 1 ) = DELTA( 1 ) / TEMP
DELTA( 2 ) = DELTA( 2 ) / TEMP
ELSE
*
* Now I=2
*
B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DEL
IF( B.GT.ZERO ) THEN
TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
ELSE
TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
END IF
DLAM = D( 2 ) + TAU
DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
DELTA( 2 ) = -Z( 2 ) / TAU
TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
DELTA( 1 ) = DELTA( 1 ) / TEMP
DELTA( 2 ) = DELTA( 2 ) / TEMP
END IF
RETURN
*
* End OF DLAED5
*
END
SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* February 2007
*
* .. Scalar Arguments ..
LOGICAL ORGATI
INTEGER INFO, KNITER
DOUBLE PRECISION FINIT, RHO, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( 3 ), Z( 3 )
* ..
*
* Purpose
* =======
*
* DLAED6 computes the positive or negative root (closest to the origin)
* of
* z(1) z(2) z(3)
* f(x) = rho + --------- + ---------- + ---------
* d(1)-x d(2)-x d(3)-x
*
* It is assumed that
*
* if ORGATI = .true. the root is between d(2) and d(3);
* otherwise it is between d(1) and d(2)
*
* This routine will be called by DLAED4 when necessary. In most cases,
* the root sought is the smallest in magnitude, though it might not be
* in some extremely rare situations.
*
* Arguments
* =========
*
* KNITER (input) INTEGER
* Refer to DLAED4 for its significance.
*
* ORGATI (input) LOGICAL
* If ORGATI is true, the needed root is between d(2) and
* d(3); otherwise it is between d(1) and d(2). See
* DLAED4 for further details.
*
* RHO (input) DOUBLE PRECISION
* Refer to the equation f(x) above.
*
* D (input) DOUBLE PRECISION array, dimension (3)
* D satisfies d(1) < d(2) < d(3).
*
* Z (input) DOUBLE PRECISION array, dimension (3)
* Each of the elements in z must be positive.
*
* FINIT (input) DOUBLE PRECISION
* The value of f at 0. It is more accurate than the one
* evaluated inside this routine (if someone wants to do
* so).
*
* TAU (output) DOUBLE PRECISION
* The root of the equation f(x).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = 1, failure to converge
*
* Further Details
* ===============
*
* 30/06/99: Based on contributions by
* Ren-Cang Li, Computer Science Division, University of California
* at Berkeley, USA
*
* 10/02/03: This version has a few statements commented out for thread
* safety (machine parameters are computed on each entry). SJH.
*
* 05/10/06: Modified from a new version of Ren-Cang Li, use
* Gragg-Thornton-Warner cubic convergent scheme for better stability.
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 40 )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Local Arrays ..
DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 )
* ..
* .. Local Scalars ..
LOGICAL SCALE
INTEGER I, ITER, NITER
DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,
$ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,
$ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4,
$ LBD, UBD
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
IF( ORGATI ) THEN
LBD = D(2)
UBD = D(3)
ELSE
LBD = D(1)
UBD = D(2)
END IF
IF( FINIT .LT. ZERO )THEN
LBD = ZERO
ELSE
UBD = ZERO
END IF
*
NITER = 1
TAU = ZERO
IF( KNITER.EQ.2 ) THEN
IF( ORGATI ) THEN
TEMP = ( D( 3 )-D( 2 ) ) / TWO
C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )
A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )
B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )
ELSE
TEMP = ( D( 1 )-D( 2 ) ) / TWO
C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )
A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )
B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )
END IF
TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
A = A / TEMP
B = B / TEMP
C = C / TEMP
IF( C.EQ.ZERO ) THEN
TAU = B / A
ELSE IF( A.LE.ZERO ) THEN
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
IF( TAU .LT. LBD .OR. TAU .GT. UBD )
$ TAU = ( LBD+UBD )/TWO
IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN
TAU = ZERO
ELSE
TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) +
$ TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) +
$ TAU*Z(3)/( D(3)*( D( 3 )-TAU ) )
IF( TEMP .LE. ZERO )THEN
LBD = TAU
ELSE
UBD = TAU
END IF
IF( ABS( FINIT ).LE.ABS( TEMP ) )
$ TAU = ZERO
END IF
END IF
*
* get machine parameters for possible scaling to avoid overflow
*
* modified by Sven: parameters SMALL1, SMINV1, SMALL2,
* SMINV2, EPS are not SAVEd anymore between one call to the
* others but recomputed at each call
*
EPS = DLAMCH( 'Epsilon' )
BASE = DLAMCH( 'Base' )
SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) /
$ THREE ) )
SMINV1 = ONE / SMALL1
SMALL2 = SMALL1*SMALL1
SMINV2 = SMINV1*SMINV1
*
* Determine if scaling of inputs necessary to avoid overflow
* when computing 1/TEMP**3
*
IF( ORGATI ) THEN
TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )
ELSE
TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )
END IF
SCALE = .FALSE.
IF( TEMP.LE.SMALL1 ) THEN
SCALE = .TRUE.
IF( TEMP.LE.SMALL2 ) THEN
*
* Scale up by power of radix nearest 1/SAFMIN**(2/3)
*
SCLFAC = SMINV2
SCLINV = SMALL2
ELSE
*
* Scale up by power of radix nearest 1/SAFMIN**(1/3)
*
SCLFAC = SMINV1
SCLINV = SMALL1
END IF
*
* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
*
DO 10 I = 1, 3
DSCALE( I ) = D( I )*SCLFAC
ZSCALE( I ) = Z( I )*SCLFAC
10 CONTINUE
TAU = TAU*SCLFAC
LBD = LBD*SCLFAC
UBD = UBD*SCLFAC
ELSE
*
* Copy D and Z to DSCALE and ZSCALE
*
DO 20 I = 1, 3
DSCALE( I ) = D( I )
ZSCALE( I ) = Z( I )
20 CONTINUE
END IF
*
FC = ZERO
DF = ZERO
DDF = ZERO
DO 30 I = 1, 3
TEMP = ONE / ( DSCALE( I )-TAU )
TEMP1 = ZSCALE( I )*TEMP
TEMP2 = TEMP1*TEMP
TEMP3 = TEMP2*TEMP
FC = FC + TEMP1 / DSCALE( I )
DF = DF + TEMP2
DDF = DDF + TEMP3
30 CONTINUE
F = FINIT + TAU*FC
*
IF( ABS( F ).LE.ZERO )
$ GO TO 60
IF( F .LE. ZERO )THEN
LBD = TAU
ELSE
UBD = TAU
END IF
*
* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent
* scheme
*
* It is not hard to see that
*
* 1) Iterations will go up monotonically
* if FINIT < 0;
*
* 2) Iterations will go down monotonically
* if FINIT > 0.
*
ITER = NITER + 1
*
DO 50 NITER = ITER, MAXIT
*
IF( ORGATI ) THEN
TEMP1 = DSCALE( 2 ) - TAU
TEMP2 = DSCALE( 3 ) - TAU
ELSE
TEMP1 = DSCALE( 1 ) - TAU
TEMP2 = DSCALE( 2 ) - TAU
END IF
A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF
B = TEMP1*TEMP2*F
C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF
TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
A = A / TEMP
B = B / TEMP
C = C / TEMP
IF( C.EQ.ZERO ) THEN
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
IF( F*ETA.GE.ZERO ) THEN
ETA = -F / DF
END IF
*
TAU = TAU + ETA
IF( TAU .LT. LBD .OR. TAU .GT. UBD )
$ TAU = ( LBD + UBD )/TWO
*
FC = ZERO
ERRETM = ZERO
DF = ZERO
DDF = ZERO
DO 40 I = 1, 3
TEMP = ONE / ( DSCALE( I )-TAU )
TEMP1 = ZSCALE( I )*TEMP
TEMP2 = TEMP1*TEMP
TEMP3 = TEMP2*TEMP
TEMP4 = TEMP1 / DSCALE( I )
FC = FC + TEMP4
ERRETM = ERRETM + ABS( TEMP4 )
DF = DF + TEMP2
DDF = DDF + TEMP3
40 CONTINUE
F = FINIT + TAU*FC
ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) +
$ ABS( TAU )*DF
IF( ABS( F ).LE.EPS*ERRETM )
$ GO TO 60
IF( F .LE. ZERO )THEN
LBD = TAU
ELSE
UBD = TAU
END IF
50 CONTINUE
INFO = 1
60 CONTINUE
*
* Undo scaling
*
IF( SCALE )
$ TAU = TAU*SCLINV
RETURN
*
* End of DLAED6
*
END
SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ,
$ TRYRAC
CHARACTER ORDER
INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE,
$ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU,
$ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN,
$ LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT
DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, DSTEIN,
$ DSTERF, DSWAP, DSYTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
IEEEOK = ILAENV( 10, 'DSYEVR', 'N', 1, 2, 3, 4 )
*
LOWER = LSAME( UPLO, 'L' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
*
LWMIN = MAX( 1, 26*N )
LIWMIN = MAX( 1, 10*N )
*
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 ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -8
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -10
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -15
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -18
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -20
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) )
LWKOPT = MAX( ( NB+1 )*N, LWMIN )
WORK( 1 ) = LWKOPT
IWORK( 1 ) = LIWMIN
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYEVR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
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 ) THEN
Z( 1, 1 ) = ONE
ISUPPZ( 1 ) = 1
ISUPPZ( 2 ) = 1
END IF
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
* Initialize indices into workspaces. Note: The IWORK indices are
* used only if DSTERF or DSTEMR fail.
* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the
* elementary reflectors used in DSYTRD.
INDTAU = 1
* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries.
INDD = INDTAU + N
* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the
* tridiagonal matrix from DSYTRD.
INDE = INDD + N
* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over
* -written by DSTEMR (the DSTERF path copies the diagonal to W).
INDDD = INDE + N
* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over
* -written while computing the eigenvalues in DSTERF and DSTEMR.
INDEE = INDDD + N
* INDWK is the starting offset of the left-over workspace, and
* LLWORK is the remaining workspace size.
INDWK = INDEE + N
LLWORK = LWORK - INDWK + 1
* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and
* stores the block indices of each of the M<=N eigenvalues.
INDIBL = 1
* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and
* stores the starting and finishing indices of each block.
INDISP = INDIBL + N
* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
* that corresponding to eigenvectors that fail to converge in
* DSTEIN. This information is discarded; if any fail, the driver
* returns INFO > 0.
INDIFL = INDISP + N
* INDIWO is the offset of the remaining integer workspace.
INDIWO = INDISP + N
*
* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
*
CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
$ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO )
*
* If all eigenvalues are desired
* then call DSTERF or DSTEMR and DORMTR.
*
IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND.
$ IEEEOK.EQ.1 ) THEN
IF( .NOT.WANTZ ) THEN
CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 )
*
IF (ABSTOL .LE. TWO*N*EPS) THEN
TRYRAC = .TRUE.
ELSE
TRYRAC = .FALSE.
END IF
CALL DSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ),
$ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ,
$ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK,
$ INFO )
*
*
*
* Apply orthogonal matrix used in reduction to tridiagonal
* form to eigenvectors returned by DSTEIN.
*
IF( WANTZ .AND. INFO.EQ.0 ) THEN
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
END IF
*
*
IF( INFO.EQ.0 ) THEN
* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are
* undefined.
M = N
GO TO 30
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN.
* Also call DSTEBZ and DSTEIN if DSTEMR fails.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ),
$ 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.
*
* Jump here if DSTEMR/DSTEIN succeeded.
30 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. Note: We do not sort the IFAIL portion of IWORK.
* It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do
* not return this detailed information to the user.
*
IF( WANTZ ) THEN
DO 50 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 40 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
40 CONTINUE
*
IF( I.NE.0 ) THEN
W( I ) = W( J )
W( J ) = TMP1
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
END IF
50 CONTINUE
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of DSYEVR
*
END
SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
$ IWORK, IFAIL, INFO )
*
* -- LAPACK routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. 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-1)
* The (n-1) subdiagonal elements of the tridiagonal matrix
* T, in elements 1 to N-1.
*
* 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.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
$ 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.
*
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
GPIND = B1
*
* 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( 2, 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
SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
$ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
$ IWORK, LIWORK, INFO )
IMPLICIT NONE
*
* -- LAPACK computational routine (version 3.2.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* -- June 2010 --
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE
LOGICAL TRYRAC
INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
DOUBLE PRECISION VL, VU
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
DOUBLE PRECISION Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DSTEMR computes selected eigenvalues and, optionally, eigenvectors
* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
* a well defined set of pairwise different real eigenvalues, the corresponding
* real eigenvectors are pairwise orthogonal.
*
* The spectrum may be computed either completely or partially by specifying
* either an interval (VL,VU] or a range of indices IL:IU for the desired
* eigenvalues.
*
* Depending on the number of desired eigenvalues, these are computed either
* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
* computed by the use of various suitable L D L^T factorizations near clusters
* of close eigenvalues (referred to as RRRs, Relatively Robust
* Representations). An informal sketch of the algorithm follows.
*
* For each unreduced block (submatrix) of T,
* (a) Compute T - sigma I = L D L^T, so that L and D
* define all the wanted eigenvalues to high relative accuracy.
* This means that small relative changes in the entries of D and L
* cause only small relative changes in the eigenvalues and
* eigenvectors. The standard (unfactored) representation of the
* tridiagonal matrix T does not have this property in general.
* (b) Compute the eigenvalues to suitable accuracy.
* If the eigenvectors are desired, the algorithm attains full
* accuracy of the computed eigenvalues only right before
* the corresponding vectors have to be computed, see steps c) and d).
* (c) For each cluster of close eigenvalues, select a new
* shift close to the cluster, find a new factorization, and refine
* the shifted eigenvalues to suitable accuracy.
* (d) For each eigenvalue with a large enough relative separation compute
* the corresponding eigenvector by forming a rank revealing twisted
* factorization. Go back to (c) for any clusters that remain.
*
* For more details, see:
* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
* 2004. Also LAPACK Working Note 154.
* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
* tridiagonal eigenvalue/eigenvector problem",
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
* Further Details
* 1.DSTEMR works only on machines which follow IEEE-754
* floating-point standard in their handling of infinities and NaNs.
* This permits the use of efficient inner loops avoiding a check for
* zero divisors.
*
* 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.
*
* 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
* T. On exit, D is overwritten.
*
* E (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the (N-1) subdiagonal elements of the tridiagonal
* matrix T in elements 1 to N-1 of E. E(N) need not be set on
* input, but is used internally as workspace.
* On exit, E is overwritten.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* If RANGE='V', the lower and upper bounds of the interval to
* be searched for eigenvalues. VL < VU.
* Not referenced if RANGE = 'A' or 'I'.
*
* IL (input) INTEGER
* IU (input) INTEGER
* If RANGE='I', the indices (in ascending order) of the
* smallest and largest eigenvalues to be returned.
* 1 <= IL <= IU <= N, if N > 0.
* Not referenced if RANGE = 'A' or 'V'.
*
* 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)
* The first M elements contain the selected eigenvalues in
* ascending order.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
* contain the orthonormal eigenvectors of the matrix T
* corresponding to the selected eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* 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 can be computed with a workspace
* query by setting NZC = -1, see below.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', then LDZ >= max(1,N).
*
* NZC (input) INTEGER
* The number of eigenvectors to be held in the array Z.
* If RANGE = 'A', then NZC >= max(1,N).
* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
* If RANGE = 'I', then NZC >= IU-IL+1.
* If NZC = -1, then a workspace query is assumed; the
* routine calculates the number of columns of the array Z that
* are needed to hold the eigenvectors.
* This value is returned as the first entry of the Z array, and
* no error message related to NZC is issued by XERBLA.
*
* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The i-th computed eigenvector
* is nonzero only in elements ISUPPZ( 2*i-1 ) through
* ISUPPZ( 2*i ). This is relevant in the case when the matrix
* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
*
* TRYRAC (input/output) LOGICAL
* If TRYRAC.EQ..TRUE., indicates that the code should check whether
* the tridiagonal matrix defines its eigenvalues to high relative
* accuracy. If so, the code uses relative-accuracy preserving
* algorithms that might be (a bit) slower depending on the matrix.
* If the matrix does not define its eigenvalues to high relative
* accuracy, the code can uses possibly faster algorithms.
* If TRYRAC.EQ..FALSE., the code is not required to guarantee
* relatively accurate eigenvalues and can use the fastest possible
* techniques.
* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
* does not define its eigenvalues to high relative accuracy.
*
* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
* On exit, if INFO = 0, WORK(1) returns the optimal
* (and minimal) LWORK.
*
* LWORK (input) INTEGER
* The dimension of the array WORK. LWORK >= max(1,18*N)
* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
* If LWORK = -1, then a workspace query is assumed; the routine
* only calculates the optimal size of the WORK array, returns
* this value as the first entry of the WORK array, and no error
* message related to LWORK is issued by XERBLA.
*
* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
* LIWORK (input) INTEGER
* The dimension of the array IWORK. LIWORK >= max(1,10*N)
* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
* if only the eigenvalues are to be computed.
* If LIWORK = -1, then a workspace query is assumed; the
* routine only calculates the optimal size of the IWORK array,
* returns this value as the first entry of the IWORK array, and
* no error message related to LIWORK is issued by XERBLA.
*
* INFO (output) INTEGER
* On exit, INFO
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = 1X, internal error in DLARRE,
* if INFO = 2X, internal error in DLARRV.
* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
* the nonzero error code returned by DLARRE or
* DLARRV, respectively.
*
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, FOUR, MINRGP
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
$ FOUR = 4.0D0,
$ MINRGP = 1.0D-3 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
INTEGER I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW,
$ IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD,
$ INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP,
$ ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT,
$ NZCMIN, OFFSET, WBEGIN, WEND
DOUBLE PRECISION BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN,
$ RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN,
$ THRESH, TMP, TNRM, WL, WU
* ..
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAE2, DLAEV2, DLARRC, DLARRE, DLARRJ,
$ DLARRR, DLARRV, DLASRT, DSCAL, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
ZQUERY = ( NZC.EQ.-1 )
* DSTEMR needs WORK of size 6*N, IWORK of size 3*N.
* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N.
* Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N.
IF( WANTZ ) THEN
LWMIN = 18*N
LIWMIN = 10*N
ELSE
* need less workspace if only the eigenvalues are wanted
LWMIN = 12*N
LIWMIN = 8*N
ENDIF
WL = ZERO
WU = ZERO
IIL = 0
IIU = 0
IF( VALEIG ) THEN
* We do not reference VL, VU in the cases RANGE = 'I','A'
* The interval (WL, WU] contains all the wanted eigenvalues.
* It is either given by the user or computed in DLARRE.
WL = VL
WU = VU
ELSEIF( INDEIG ) THEN
* We do not reference IL, IU in the cases RANGE = 'V','A'
IIL = IL
IIU = IU
ENDIF
*
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( N.LT.0 ) THEN
INFO = -3
ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN
INFO = -7
ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN
INFO = -8
ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -13
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -17
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -19
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 ) ) )
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( WANTZ .AND. ALLEIG ) THEN
NZCMIN = N
ELSE IF( WANTZ .AND. VALEIG ) THEN
CALL DLARRC( 'T', N, VL, VU, D, E, SAFMIN,
$ NZCMIN, ITMP, ITMP2, INFO )
ELSE IF( WANTZ .AND. INDEIG ) THEN
NZCMIN = IIU-IIL+1
ELSE
* WANTZ .EQ. FALSE.
NZCMIN = 0
ENDIF
IF( ZQUERY .AND. INFO.EQ.0 ) THEN
Z( 1,1 ) = NZCMIN
ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN
INFO = -14
END IF
END IF
IF( INFO.NE.0 ) THEN
*
CALL XERBLA( 'DSTEMR', -INFO )
*
RETURN
ELSE IF( LQUERY .OR. ZQUERY ) THEN
RETURN
END IF
*
* Handle N = 0, 1, and 2 cases immediately
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = D( 1 )
ELSE
IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
M = 1
W( 1 ) = D( 1 )
END IF
END IF
IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
Z( 1, 1 ) = ONE
ISUPPZ(1) = 1
ISUPPZ(2) = 1
END IF
RETURN
END IF
*
IF( N.EQ.2 ) THEN
IF( .NOT.WANTZ ) THEN
CALL DLAE2( D(1), E(1), D(2), R1, R2 )
ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
CALL DLAEV2( D(1), E(1), D(2), R1, R2, CS, SN )
END IF
IF( ALLEIG.OR.
$ (VALEIG.AND.(R2.GT.WL).AND.
$ (R2.LE.WU)).OR.
$ (INDEIG.AND.(IIL.EQ.1)) ) THEN
M = M+1
W( M ) = R2
IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
Z( 1, M ) = -SN
Z( 2, M ) = CS
* Note: At most one of SN and CS can be zero.
IF (SN.NE.ZERO) THEN
IF (CS.NE.ZERO) THEN
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M) = 2
ELSE
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M) = 1
END IF
ELSE
ISUPPZ(2*M-1) = 2
ISUPPZ(2*M) = 2
END IF
ENDIF
ENDIF
IF( ALLEIG.OR.
$ (VALEIG.AND.(R1.GT.WL).AND.
$ (R1.LE.WU)).OR.
$ (INDEIG.AND.(IIU.EQ.2)) ) THEN
M = M+1
W( M ) = R1
IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
Z( 1, M ) = CS
Z( 2, M ) = SN
* Note: At most one of SN and CS can be zero.
IF (SN.NE.ZERO) THEN
IF (CS.NE.ZERO) THEN
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M) = 2
ELSE
ISUPPZ(2*M-1) = 1
ISUPPZ(2*M) = 1
END IF
ELSE
ISUPPZ(2*M-1) = 2
ISUPPZ(2*M) = 2
END IF
ENDIF
ENDIF
RETURN
END IF
* Continue with general N
INDGRS = 1
INDERR = 2*N + 1
INDGP = 3*N + 1
INDD = 4*N + 1
INDE2 = 5*N + 1
INDWRK = 6*N + 1
*
IINSPL = 1
IINDBL = N + 1
IINDW = 2*N + 1
IINDWK = 3*N + 1
*
* Scale matrix to allowable range, if necessary.
* The allowable range is related to the PIVMIN parameter; see the
* comments in DLARRD. The preference for scaling small values
* up is heuristic; we expect users' matrices not to be close to the
* RMAX threshold.
*
SCALE = ONE
TNRM = DLANST( 'M', N, D, E )
IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
SCALE = RMIN / TNRM
ELSE IF( TNRM.GT.RMAX ) THEN
SCALE = RMAX / TNRM
END IF
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( N, SCALE, D, 1 )
CALL DSCAL( N-1, SCALE, E, 1 )
TNRM = TNRM*SCALE
IF( VALEIG ) THEN
* If eigenvalues in interval have to be found,
* scale (WL, WU] accordingly
WL = WL*SCALE
WU = WU*SCALE
ENDIF
END IF
*
* Compute the desired eigenvalues of the tridiagonal after splitting
* into smaller subblocks if the corresponding off-diagonal elements
* are small
* THRESH is the splitting parameter for DLARRE
* A negative THRESH forces the old splitting criterion based on the
* size of the off-diagonal. A positive THRESH switches to splitting
* which preserves relative accuracy.
*
IF( TRYRAC ) THEN
* Test whether the matrix warrants the more expensive relative approach.
CALL DLARRR( N, D, E, IINFO )
ELSE
* The user does not care about relative accurately eigenvalues
IINFO = -1
ENDIF
* Set the splitting criterion
IF (IINFO.EQ.0) THEN
THRESH = EPS
ELSE
THRESH = -EPS
* relative accuracy is desired but T does not guarantee it
TRYRAC = .FALSE.
ENDIF
*
IF( TRYRAC ) THEN
* Copy original diagonal, needed to guarantee relative accuracy
CALL DCOPY(N,D,1,WORK(INDD),1)
ENDIF
* Store the squares of the offdiagonal values of T
DO 5 J = 1, N-1
WORK( INDE2+J-1 ) = E(J)**2
5 CONTINUE
* Set the tolerance parameters for bisection
IF( .NOT.WANTZ ) THEN
* DLARRE computes the eigenvalues to full precision.
RTOL1 = FOUR * EPS
RTOL2 = FOUR * EPS
ELSE
* DLARRE computes the eigenvalues to less than full precision.
* DLARRV will refine the eigenvalue approximations, and we can
* need less accurate initial bisection in DLARRE.
* Note: these settings do only affect the subset case and DLARRE
RTOL1 = SQRT(EPS)
RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS )
ENDIF
CALL DLARRE( RANGE, N, WL, WU, IIL, IIU, D, E,
$ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
$ IWORK( IINSPL ), M, W, WORK( INDERR ),
$ WORK( INDGP ), IWORK( IINDBL ),
$ IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
$ WORK( INDWRK ), IWORK( IINDWK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 10 + ABS( IINFO )
RETURN
END IF
* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired
* part of the spectrum. All desired eigenvalues are contained in
* (WL,WU]
IF( WANTZ ) THEN
*
* Compute the desired eigenvectors corresponding to the computed
* eigenvalues
*
CALL DLARRV( N, WL, WU, D, E,
$ PIVMIN, IWORK( IINSPL ), M,
$ 1, M, MINRGP, RTOL1, RTOL2,
$ W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
$ IWORK( IINDW ), WORK( INDGRS ), Z, LDZ,
$ ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 20 + ABS( IINFO )
RETURN
END IF
ELSE
* DLARRE computes eigenvalues of the (shifted) root representation
* DLARRV returns the eigenvalues of the unshifted matrix.
* However, if the eigenvectors are not desired by the user, we need
* to apply the corresponding shifts from DLARRE to obtain the
* eigenvalues of the original matrix.
DO 20 J = 1, M
ITMP = IWORK( IINDBL+J-1 )
W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
20 CONTINUE
END IF
*
IF ( TRYRAC ) THEN
* Refine computed eigenvalues so that they are relatively accurate
* with respect to the original matrix T.
IBEGIN = 1
WBEGIN = 1
DO 39 JBLK = 1, IWORK( IINDBL+M-1 )
IEND = IWORK( IINSPL+JBLK-1 )
IN = IEND - IBEGIN + 1
WEND = WBEGIN - 1
* check if any eigenvalues have to be refined in this block
36 CONTINUE
IF( WEND.LT.M ) THEN
IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN
WEND = WEND + 1
GO TO 36
END IF
END IF
IF( WEND.LT.WBEGIN ) THEN
IBEGIN = IEND + 1
GO TO 39
END IF
OFFSET = IWORK(IINDW+WBEGIN-1)-1
IFIRST = IWORK(IINDW+WBEGIN-1)
ILAST = IWORK(IINDW+WEND-1)
RTOL2 = FOUR * EPS
CALL DLARRJ( IN,
$ WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1),
$ IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN),
$ WORK( INDERR+WBEGIN-1 ),
$ WORK( INDWRK ), IWORK( IINDWK ), PIVMIN,
$ TNRM, IINFO )
IBEGIN = IEND + 1
WBEGIN = WEND + 1
39 CONTINUE
ENDIF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( SCALE.NE.ONE ) THEN
CALL DSCAL( M, ONE / SCALE, W, 1 )
END IF
*
* If eigenvalues are not in increasing order, then sort them,
* possibly along with eigenvectors.
*
IF( NSPLIT.GT.1 ) THEN
IF( .NOT. WANTZ ) THEN
CALL DLASRT( 'I', M, W, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = 3
RETURN
END IF
ELSE
DO 60 J = 1, M - 1
I = 0
TMP = W( J )
DO 50 JJ = J + 1, M
IF( W( JJ ).LT.TMP ) THEN
I = JJ
TMP = W( JJ )
END IF
50 CONTINUE
IF( I.NE.0 ) THEN
W( I ) = W( J )
W( J ) = TMP
IF( WANTZ ) THEN
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
ITMP = ISUPPZ( 2*I-1 )
ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
ISUPPZ( 2*J-1 ) = ITMP
ITMP = ISUPPZ( 2*I )
ISUPPZ( 2*I ) = ISUPPZ( 2*J )
ISUPPZ( 2*J ) = ITMP
END IF
END IF
60 CONTINUE
END IF
ENDIF
*
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
RETURN
*
* End of DSTEMR
*
END
SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN,
$ ISPLIT, M, DOL, DOU, MINRGP,
$ RTOL1, RTOL2, W, WERR, WGAP,
$ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ,
$ WORK, IWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.3.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* -- April 2011 --
*
* .. Scalar Arguments ..
INTEGER DOL, DOU, INFO, LDZ, M, N
DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
$ ISUPPZ( * ), IWORK( * )
DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
$ WGAP( * ), WORK( * )
DOUBLE PRECISION Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DLARRV computes the eigenvectors of the tridiagonal matrix
* T = L D L**T given L, D and APPROXIMATIONS to the eigenvalues of L D L**T.
* The input eigenvalues should have been computed by DLARRE.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* VL (input) DOUBLE PRECISION
* VU (input) DOUBLE PRECISION
* Lower and upper bounds of the interval that contains the desired
* eigenvalues. VL < VU. Needed to compute gaps on the left or right
* end of the extremal eigenvalues in the desired RANGE.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the N diagonal elements of the diagonal matrix D.
* On exit, D may be overwritten.
*
* L (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the (N-1) subdiagonal elements of the unit
* bidiagonal matrix L are in elements 1 to N-1 of L
* (if the matrix is not splitted.) At the end of each block
* is stored the corresponding shift as given by DLARRE.
* On exit, L is overwritten.
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot allowed in the Sturm sequence.
*
* ISPLIT (input) INTEGER array, dimension (N)
* The splitting points, at which T breaks up into blocks.
* The first block consists of rows/columns 1 to
* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
* through ISPLIT( 2 ), etc.
*
* M (input) INTEGER
* The total number of input eigenvalues. 0 <= M <= N.
*
* DOL (input) INTEGER
* DOU (input) INTEGER
* If the user wants to compute only selected eigenvectors from all
* the eigenvalues supplied, he can specify an index range DOL:DOU.
* Or else the setting DOL=1, DOU=M should be applied.
* Note that DOL and DOU refer to the order in which the eigenvalues
* are stored in W.
* If the user wants to compute only selected eigenpairs, then
* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
* computed eigenvectors. All other columns of Z are set to zero.
*
* MINRGP (input) DOUBLE PRECISION
*
* RTOL1 (input) DOUBLE PRECISION
* RTOL2 (input) DOUBLE PRECISION
* Parameters for bisection.
* An interval [LEFT,RIGHT] has converged if
* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
*
* W (input/output) DOUBLE PRECISION array, dimension (N)
* The first M elements of W contain the APPROXIMATE 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 DLARRE is expected here ). Furthermore, they are with
* respect to the shift of the corresponding root representation
* for their block. On exit, W holds the eigenvalues of the
* UNshifted matrix.
*
* WERR (input/output) DOUBLE PRECISION array, dimension (N)
* The first M elements contain the semiwidth of the uncertainty
* interval of the corresponding eigenvalue in W
*
* WGAP (input/output) DOUBLE PRECISION array, dimension (N)
* The separation from the right neighbor eigenvalue in W.
*
* IBLOCK (input) INTEGER array, dimension (N)
* The indices of the blocks (submatrices) associated with the
* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
* W(i) belongs to the first block from the top, =2 if W(i)
* belongs to the second block, etc.
*
* INDEXW (input) INTEGER array, dimension (N)
* The indices of the eigenvalues within each block (submatrix);
* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
*
* GERS (input) DOUBLE PRECISION array, dimension (2*N)
* The N Gerschgorin intervals (the i-th Gerschgorin interval
* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
* be computed from the original UNshifted matrix.
*
* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
* If INFO = 0, the first M columns of Z contain the
* orthonormal eigenvectors of the matrix T
* corresponding to the input eigenvalues, with the i-th
* column of Z holding the eigenvector associated with W(i).
* Note: the user must ensure that at least max(1,M) columns are
* supplied in the array Z.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
* The support of the eigenvectors in Z, i.e., the indices
* indicating the nonzero elements in Z. The I-th eigenvector
* is nonzero only in elements ISUPPZ( 2*I-1 ) through
* ISUPPZ( 2*I ).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (12*N)
*
* IWORK (workspace) INTEGER array, dimension (7*N)
*
* INFO (output) INTEGER
* = 0: successful exit
*
* > 0: A problem occured in DLARRV.
* < 0: One of the called subroutines signaled an internal problem.
* Needs inspection of the corresponding parameter IINFO
* for further information.
*
* =-1: Problem in DLARRB when refining a child's eigenvalues.
* =-2: Problem in DLARRF when computing the RRR of a child.
* When a child is inside a tight cluster, it can be difficult
* to find an RRR. A partial remedy from the user's point of
* view is to make the parameter MINRGP smaller and recompile.
* However, as the orthogonality of the computed vectors is
* proportional to 1/MINRGP, the user should be aware that
* he might be trading in precision when he decreases MINRGP.
* =-3: Problem in DLARRB when refining a single eigenvalue
* after the Rayleigh correction was rejected.
* = 5: The Rayleigh Quotient Iteration failed to converge to
* full accuracy in MAXITR steps.
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXITR
PARAMETER ( MAXITR = 10 )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, HALF
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, THREE = 3.0D0,
$ FOUR = 4.0D0, HALF = 0.5D0)
* ..
* .. Local Scalars ..
LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
$ IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG,
$ INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER,
$ ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS,
$ NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST,
$ NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST,
$ OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX,
$ WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU,
$ ZUSEDW
DOUBLE PRECISION BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
$ LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID,
$ RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF,
$ SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAR1V, DLARRB, DLARRF, DLASET,
$ DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN
* ..
* .. Executable Statements ..
* ..
* The first N entries of WORK are reserved for the eigenvalues
INDLD = N+1
INDLLD= 2*N+1
INDWRK= 3*N+1
MINWSIZE = 12 * N
DO 5 I= 1,MINWSIZE
WORK( I ) = ZERO
5 CONTINUE
* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the
* factorization used to compute the FP vector
IINDR = 0
* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current
* layer and the one above.
IINDC1 = N
IINDC2 = 2*N
IINDWK = 3*N + 1
MINIWSIZE = 7 * N
DO 10 I= 1,MINIWSIZE
IWORK( I ) = 0
10 CONTINUE
ZUSEDL = 1
IF(DOL.GT.1) THEN
* Set lower bound for use of Z
ZUSEDL = DOL-1
ENDIF
ZUSEDU = M
IF(DOU.LT.M) THEN
* Set lower bound for use of Z
ZUSEDU = DOU+1
ENDIF
* The width of the part of Z that is used
ZUSEDW = ZUSEDU - ZUSEDL + 1
CALL DLASET( 'Full', N, ZUSEDW, ZERO, ZERO,
$ Z(1,ZUSEDL), LDZ )
EPS = DLAMCH( 'Precision' )
RQTOL = TWO * EPS
*
* Set expert flags for standard code.
TRYRQC = .TRUE.
IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
ELSE
* Only selected eigenpairs are computed. Since the other evalues
* are not refined by RQ iteration, bisection has to compute to full
* accuracy.
RTOL1 = FOUR * EPS
RTOL2 = FOUR * EPS
ENDIF
* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
* desired eigenvalues. The support of the nonzero eigenvector
* entries is contained in the interval IBEGIN:IEND.
* Remark that if k eigenpairs are desired, then the eigenvectors
* are stored in k contiguous columns of Z.
* DONE is the number of eigenvectors already computed
DONE = 0
IBEGIN = 1
WBEGIN = 1
DO 170 JBLK = 1, IBLOCK( M )
IEND = ISPLIT( JBLK )
SIGMA = L( IEND )
* Find the eigenvectors of the submatrix indexed IBEGIN
* through IEND.
WEND = WBEGIN - 1
15 CONTINUE
IF( WEND.LT.M ) THEN
IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN
WEND = WEND + 1
GO TO 15
END IF
END IF
IF( WEND.LT.WBEGIN ) THEN
IBEGIN = IEND + 1
GO TO 170
ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
IBEGIN = IEND + 1
WBEGIN = WEND + 1
GO TO 170
END IF
* Find local spectral diameter of the block
GL = GERS( 2*IBEGIN-1 )
GU = GERS( 2*IBEGIN )
DO 20 I = IBEGIN+1 , IEND
GL = MIN( GERS( 2*I-1 ), GL )
GU = MAX( GERS( 2*I ), GU )
20 CONTINUE
SPDIAM = GU - GL
* OLDIEN is the last index of the previous block
OLDIEN = IBEGIN - 1
* Calculate the size of the current block
IN = IEND - IBEGIN + 1
* The number of eigenvalues in the current block
IM = WEND - WBEGIN + 1
* This is for a 1x1 block
IF( IBEGIN.EQ.IEND ) THEN
DONE = DONE+1
Z( IBEGIN, WBEGIN ) = ONE
ISUPPZ( 2*WBEGIN-1 ) = IBEGIN
ISUPPZ( 2*WBEGIN ) = IBEGIN
W( WBEGIN ) = W( WBEGIN ) + SIGMA
WORK( WBEGIN ) = W( WBEGIN )
IBEGIN = IEND + 1
WBEGIN = WBEGIN + 1
GO TO 170
END IF
* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND)
* Note that these can be approximations, in this case, the corresp.
* entries of WERR give the size of the uncertainty interval.
* The eigenvalue approximations will be refined when necessary as
* high relative accuracy is required for the computation of the
* corresponding eigenvectors.
CALL DCOPY( IM, W( WBEGIN ), 1,
$ WORK( WBEGIN ), 1 )
* We store in W the eigenvalue approximations w.r.t. the original
* matrix T.
DO 30 I=1,IM
W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA
30 CONTINUE
* NDEPTH is the current depth of the representation tree
NDEPTH = 0
* PARITY is either 1 or 0
PARITY = 1
* NCLUS is the number of clusters for the next level of the
* representation tree, we start with NCLUS = 1 for the root
NCLUS = 1
IWORK( IINDC1+1 ) = 1
IWORK( IINDC1+2 ) = IM
* IDONE is the number of eigenvectors already computed in the current
* block
IDONE = 0
* loop while( IDONE.LT.IM )
* generate the representation tree for the current block and
* compute the eigenvectors
40 CONTINUE
IF( IDONE.LT.IM ) THEN
* This is a crude protection against infinitely deep trees
IF( NDEPTH.GT.M ) THEN
INFO = -2
RETURN
ENDIF
* breadth first processing of the current level of the representation
* tree: OLDNCL = number of clusters on current level
OLDNCL = NCLUS
* reset NCLUS to count the number of child clusters
NCLUS = 0
*
PARITY = 1 - PARITY
IF( PARITY.EQ.0 ) THEN
OLDCLS = IINDC1
NEWCLS = IINDC2
ELSE
OLDCLS = IINDC2
NEWCLS = IINDC1
END IF
* Process the clusters on the current level
DO 150 I = 1, OLDNCL
J = OLDCLS + 2*I
* OLDFST, OLDLST = first, last index of current cluster.
* cluster indices start with 1 and are relative
* to WBEGIN when accessing W, WGAP, WERR, Z
OLDFST = IWORK( J-1 )
OLDLST = IWORK( J )
IF( NDEPTH.GT.0 ) THEN
* Retrieve relatively robust representation (RRR) of cluster
* that has been computed at the previous level
* The RRR is stored in Z and overwritten once the eigenvectors
* have been computed or when the cluster is refined
IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
* Get representation from location of the leftmost evalue
* of the cluster
J = WBEGIN + OLDFST - 1
ELSE
IF(WBEGIN+OLDFST-1.LT.DOL) THEN
* Get representation from the left end of Z array
J = DOL - 1
ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN
* Get representation from the right end of Z array
J = DOU
ELSE
J = WBEGIN + OLDFST - 1
ENDIF
ENDIF
CALL DCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 )
CALL DCOPY( IN-1, Z( IBEGIN, J+1 ), 1, L( IBEGIN ),
$ 1 )
SIGMA = Z( IEND, J+1 )
* Set the corresponding entries in Z to zero
CALL DLASET( 'Full', IN, 2, ZERO, ZERO,
$ Z( IBEGIN, J), LDZ )
END IF
* Compute DL and DLL of current RRR
DO 50 J = IBEGIN, IEND-1
TMP = D( J )*L( J )
WORK( INDLD-1+J ) = TMP
WORK( INDLLD-1+J ) = TMP*L( J )
50 CONTINUE
IF( NDEPTH.GT.0 ) THEN
* P and Q are index of the first and last eigenvalue to compute
* within the current block
P = INDEXW( WBEGIN-1+OLDFST )
Q = INDEXW( WBEGIN-1+OLDLST )
* Offset for the arrays WORK, WGAP and WERR, i.e., the P-OFFSET
* through the Q-OFFSET elements of these arrays are to be used.
* OFFSET = P-OLDFST
OFFSET = INDEXW( WBEGIN ) - 1
* perform limited bisection (if necessary) to get approximate
* eigenvalues to the precision needed.
CALL DLARRB( IN, D( IBEGIN ),
$ WORK(INDLLD+IBEGIN-1),
$ P, Q, RTOL1, RTOL2, OFFSET,
$ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
$ WORK( INDWRK ), IWORK( IINDWK ),
$ PIVMIN, SPDIAM, IN, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -1
RETURN
ENDIF
* We also recompute the extremal gaps. W holds all eigenvalues
* of the unshifted matrix and must be used for computation
* of WGAP, the entries of WORK might stem from RRRs with
* different shifts. The gaps from WBEGIN-1+OLDFST to
* WBEGIN-1+OLDLST are correctly computed in DLARRB.
* However, we only allow the gaps to become greater since
* this is what should happen when we decrease WERR
IF( OLDFST.GT.1) THEN
WGAP( WBEGIN+OLDFST-2 ) =
$ MAX(WGAP(WBEGIN+OLDFST-2),
$ W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1)
$ - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) )
ENDIF
IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN
WGAP( WBEGIN+OLDLST-1 ) =
$ MAX(WGAP(WBEGIN+OLDLST-1),
$ W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST)
$ - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) )
ENDIF
* Each time the eigenvalues in WORK get refined, we store
* the newly found approximation with all shifts applied in W
DO 53 J=OLDFST,OLDLST
W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA
53 CONTINUE
END IF
* Process the current node.
NEWFST = OLDFST
DO 140 J = OLDFST, OLDLST
IF( J.EQ.OLDLST ) THEN
* we are at the right end of the cluster, this is also the
* boundary of the child cluster
NEWLST = J
ELSE IF ( WGAP( WBEGIN + J -1).GE.
$ MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN
* the right relative gap is big enough, the child cluster
* (NEWFST,..,NEWLST) is well separated from the following
NEWLST = J
ELSE
* inside a child cluster, the relative gap is not
* big enough.
GOTO 140
END IF
* Compute size of child cluster found
NEWSIZ = NEWLST - NEWFST + 1
* NEWFTT is the place in Z where the new RRR or the computed
* eigenvector is to be stored
IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
* Store representation at location of the leftmost evalue
* of the cluster
NEWFTT = WBEGIN + NEWFST - 1
ELSE
IF(WBEGIN+NEWFST-1.LT.DOL) THEN
* Store representation at the left end of Z array
NEWFTT = DOL - 1
ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN
* Store representation at the right end of Z array
NEWFTT = DOU
ELSE
NEWFTT = WBEGIN + NEWFST - 1
ENDIF
ENDIF
IF( NEWSIZ.GT.1) THEN
*
* Current child is not a singleton but a cluster.
* Compute and store new representation of child.
*
*
* Compute left and right cluster gap.
*
* LGAP and RGAP are not computed from WORK because
* the eigenvalue approximations may stem from RRRs
* different shifts. However, W hold all eigenvalues
* of the unshifted matrix. Still, the entries in WGAP
* have to be computed from WORK since the entries
* in W might be of the same order so that gaps are not
* exhibited correctly for very close eigenvalues.
IF( NEWFST.EQ.1 ) THEN
LGAP = MAX( ZERO,
$ W(WBEGIN)-WERR(WBEGIN) - VL )
ELSE
LGAP = WGAP( WBEGIN+NEWFST-2 )
ENDIF
RGAP = WGAP( WBEGIN+NEWLST-1 )
*
* Compute left- and rightmost eigenvalue of child
* to high precision in order to shift as close
* as possible and obtain as large relative gaps
* as possible
*
DO 55 K =1,2
IF(K.EQ.1) THEN
P = INDEXW( WBEGIN-1+NEWFST )
ELSE
P = INDEXW( WBEGIN-1+NEWLST )
ENDIF
OFFSET = INDEXW( WBEGIN ) - 1
CALL DLARRB( IN, D(IBEGIN),
$ WORK( INDLLD+IBEGIN-1 ),P,P,
$ RQTOL, RQTOL, OFFSET,
$ WORK(WBEGIN),WGAP(WBEGIN),
$ WERR(WBEGIN),WORK( INDWRK ),
$ IWORK( IINDWK ), PIVMIN, SPDIAM,
$ IN, IINFO )
55 CONTINUE
*
IF((WBEGIN+NEWLST-1.LT.DOL).OR.
$ (WBEGIN+NEWFST-1.GT.DOU)) THEN
* if the cluster contains no desired eigenvalues
* skip the computation of that branch of the rep. tree
*
* We could skip before the refinement of the extremal
* eigenvalues of the child, but then the representation
* tree could be different from the one when nothing is
* skipped. For this reason we skip at this place.
IDONE = IDONE + NEWLST - NEWFST + 1
GOTO 139
ENDIF
*
* Compute RRR of child cluster.
* Note that the new RRR is stored in Z
*
* DLARRF needs LWORK = 2*N
CALL DLARRF( IN, D( IBEGIN ), L( IBEGIN ),
$ WORK(INDLD+IBEGIN-1),
$ NEWFST, NEWLST, WORK(WBEGIN),
$ WGAP(WBEGIN), WERR(WBEGIN),
$ SPDIAM, LGAP, RGAP, PIVMIN, TAU,
$ Z(IBEGIN, NEWFTT),Z(IBEGIN, NEWFTT+1),
$ WORK( INDWRK ), IINFO )
IF( IINFO.EQ.0 ) THEN
* a new RRR for the cluster was found by DLARRF
* update shift and store it
SSIGMA = SIGMA + TAU
Z( IEND, NEWFTT+1 ) = SSIGMA
* WORK() are the midpoints and WERR() the semi-width
* Note that the entries in W are unchanged.
DO 116 K = NEWFST, NEWLST
FUDGE =
$ THREE*EPS*ABS(WORK(WBEGIN+K-1))
WORK( WBEGIN + K - 1 ) =
$ WORK( WBEGIN + K - 1) - TAU
FUDGE = FUDGE +
$ FOUR*EPS*ABS(WORK(WBEGIN+K-1))
* Fudge errors
WERR( WBEGIN + K - 1 ) =
$ WERR( WBEGIN + K - 1 ) + FUDGE
* Gaps are not fudged. Provided that WERR is small
* when eigenvalues are close, a zero gap indicates
* that a new representation is needed for resolving
* the cluster. A fudge could lead to a wrong decision
* of judging eigenvalues 'separated' which in
* reality are not. This could have a negative impact
* on the orthogonality of the computed eigenvectors.
116 CONTINUE
NCLUS = NCLUS + 1
K = NEWCLS + 2*NCLUS
IWORK( K-1 ) = NEWFST
IWORK( K ) = NEWLST
ELSE
INFO = -2
RETURN
ENDIF
ELSE
*
* Compute eigenvector of singleton
*
ITER = 0
*
TOL = FOUR * LOG(DBLE(IN)) * EPS
*
K = NEWFST
WINDEX = WBEGIN + K - 1
WINDMN = MAX(WINDEX - 1,1)
WINDPL = MIN(WINDEX + 1,M)
LAMBDA = WORK( WINDEX )
DONE = DONE + 1
* Check if eigenvector computation is to be skipped
IF((WINDEX.LT.DOL).OR.
$ (WINDEX.GT.DOU)) THEN
ESKIP = .TRUE.
GOTO 125
ELSE
ESKIP = .FALSE.
ENDIF
LEFT = WORK( WINDEX ) - WERR( WINDEX )
RIGHT = WORK( WINDEX ) + WERR( WINDEX )
INDEIG = INDEXW( WINDEX )
* Note that since we compute the eigenpairs for a child,
* all eigenvalue approximations are w.r.t the same shift.
* In this case, the entries in WORK should be used for
* computing the gaps since they exhibit even very small
* differences in the eigenvalues, as opposed to the
* entries in W which might "look" the same.
IF( K .EQ. 1) THEN
* In the case RANGE='I' and with not much initial
* accuracy in LAMBDA and VL, the formula
* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
* can lead to an overestimation of the left gap and
* thus to inadequately early RQI 'convergence'.
* Prevent this by forcing a small left gap.
LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
ELSE
LGAP = WGAP(WINDMN)
ENDIF
IF( K .EQ. IM) THEN
* In the case RANGE='I' and with not much initial
* accuracy in LAMBDA and VU, the formula
* can lead to an overestimation of the right gap and
* thus to inadequately early RQI 'convergence'.
* Prevent this by forcing a small right gap.
RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
ELSE
RGAP = WGAP(WINDEX)
ENDIF
GAP = MIN( LGAP, RGAP )
IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN
* The eigenvector support can become wrong
* because significant entries could be cut off due to a
* large GAPTOL parameter in LAR1V. Prevent this.
GAPTOL = ZERO
ELSE
GAPTOL = GAP * EPS
ENDIF
ISUPMN = IN
ISUPMX = 1
* Update WGAP so that it holds the minimum gap
* to the left or the right. This is crucial in the
* case where bisection is used to ensure that the
* eigenvalue is refined up to the required precision.
* The correct value is restored afterwards.
SAVGAP = WGAP(WINDEX)
WGAP(WINDEX) = GAP
* We want to use the Rayleigh Quotient Correction
* as often as possible since it converges quadratically
* when we are close enough to the desired eigenvalue.
* However, the Rayleigh Quotient can have the wrong sign
* and lead us away from the desired eigenvalue. In this
* case, the best we can do is to use bisection.
USEDBS = .FALSE.
USEDRQ = .FALSE.
* Bisection is initially turned off unless it is forced
NEEDBS = .NOT.TRYRQC
120 CONTINUE
* Check if bisection should be used to refine eigenvalue
IF(NEEDBS) THEN
* Take the bisection as new iterate
USEDBS = .TRUE.
ITMP1 = IWORK( IINDR+WINDEX )
OFFSET = INDEXW( WBEGIN ) - 1
CALL DLARRB( IN, D(IBEGIN),
$ WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG,
$ ZERO, TWO*EPS, OFFSET,
$ WORK(WBEGIN),WGAP(WBEGIN),
$ WERR(WBEGIN),WORK( INDWRK ),
$ IWORK( IINDWK ), PIVMIN, SPDIAM,
$ ITMP1, IINFO )
IF( IINFO.NE.0 ) THEN
INFO = -3
RETURN
ENDIF
LAMBDA = WORK( WINDEX )
* Reset twist index from inaccurate LAMBDA to
* force computation of true MINGMA
IWORK( IINDR+WINDEX ) = 0
ENDIF
* Given LAMBDA, compute the eigenvector.
CALL DLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ),
$ L( IBEGIN ), WORK(INDLD+IBEGIN-1),
$ WORK(INDLLD+IBEGIN-1),
$ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
$ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
$ IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ),
$ NRMINV, RESID, RQCORR, WORK( INDWRK ) )
IF(ITER .EQ. 0) THEN
BSTRES = RESID
BSTW = LAMBDA
ELSEIF(RESID.LT.BSTRES) THEN
BSTRES = RESID
BSTW = LAMBDA
ENDIF
ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 ))
ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX ))
ITER = ITER + 1
* sin alpha <= |resid|/gap
* Note that both the residual and the gap are
* proportional to the matrix, so ||T|| doesn't play
* a role in the quotient
*
* Convergence test for Rayleigh-Quotient iteration
* (omitted when Bisection has been used)
*
IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT.
$ RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS)
$ THEN
* We need to check that the RQCORR update doesn't
* move the eigenvalue away from the desired one and
* towards a neighbor. -> protection with bisection
IF(INDEIG.LE.NEGCNT) THEN
* The wanted eigenvalue lies to the left
SGNDEF = -ONE
ELSE
* The wanted eigenvalue lies to the right
SGNDEF = ONE
ENDIF
* We only use the RQCORR if it improves the
* the iterate reasonably.
IF( ( RQCORR*SGNDEF.GE.ZERO )
$ .AND.( LAMBDA + RQCORR.LE. RIGHT)
$ .AND.( LAMBDA + RQCORR.GE. LEFT)
$ ) THEN
USEDRQ = .TRUE.
* Store new midpoint of bisection interval in WORK
IF(SGNDEF.EQ.ONE) THEN
* The current LAMBDA is on the left of the true
* eigenvalue
LEFT = LAMBDA
* We prefer to assume that the error estimate
* is correct. We could make the interval not
* as a bracket but to be modified if the RQCORR
* chooses to. In this case, the RIGHT side should
* be modified as follows:
* RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
ELSE
* The current LAMBDA is on the right of the true
* eigenvalue
RIGHT = LAMBDA
* See comment about assuming the error estimate is
* correct above.
* LEFT = MIN(LEFT, LAMBDA + RQCORR)
ENDIF
WORK( WINDEX ) =
$ HALF * (RIGHT + LEFT)
* Take RQCORR since it has the correct sign and
* improves the iterate reasonably
LAMBDA = LAMBDA + RQCORR
* Update width of error interval
WERR( WINDEX ) =
$ HALF * (RIGHT-LEFT)
ELSE
NEEDBS = .TRUE.
ENDIF
IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN
* The eigenvalue is computed to bisection accuracy
* compute eigenvector and stop
USEDBS = .TRUE.
GOTO 120
ELSEIF( ITER.LT.MAXITR ) THEN
GOTO 120
ELSEIF( ITER.EQ.MAXITR ) THEN
NEEDBS = .TRUE.
GOTO 120
ELSE
INFO = 5
RETURN
END IF
ELSE
STP2II = .FALSE.
IF(USEDRQ .AND. USEDBS .AND.
$ BSTRES.LE.RESID) THEN
LAMBDA = BSTW
STP2II = .TRUE.
ENDIF
IF (STP2II) THEN
* improve error angle by second step
CALL DLAR1V( IN, 1, IN, LAMBDA,
$ D( IBEGIN ), L( IBEGIN ),
$ WORK(INDLD+IBEGIN-1),
$ WORK(INDLLD+IBEGIN-1),
$ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
$ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
$ IWORK( IINDR+WINDEX ),
$ ISUPPZ( 2*WINDEX-1 ),
$ NRMINV, RESID, RQCORR, WORK( INDWRK ) )
ENDIF
WORK( WINDEX ) = LAMBDA
END IF
*
* Compute FP-vector support w.r.t. whole matrix
*
ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN
ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN
ZFROM = ISUPPZ( 2*WINDEX-1 )
ZTO = ISUPPZ( 2*WINDEX )
ISUPMN = ISUPMN + OLDIEN
ISUPMX = ISUPMX + OLDIEN
* Ensure vector is ok if support in the RQI has changed
IF(ISUPMN.LT.ZFROM) THEN
DO 122 II = ISUPMN,ZFROM-1
Z( II, WINDEX ) = ZERO
122 CONTINUE
ENDIF
IF(ISUPMX.GT.ZTO) THEN
DO 123 II = ZTO+1,ISUPMX
Z( II, WINDEX ) = ZERO
123 CONTINUE
ENDIF
CALL DSCAL( ZTO-ZFROM+1, NRMINV,
$ Z( ZFROM, WINDEX ), 1 )
125 CONTINUE
* Update W
W( WINDEX ) = LAMBDA+SIGMA
* Recompute the gaps on the left and right
* But only allow them to become larger and not
* smaller (which can only happen through "bad"
* cancellation and doesn't reflect the theory
* where the initial gaps are underestimated due
* to WERR being too crude.)
IF(.NOT.ESKIP) THEN
IF( K.GT.1) THEN
WGAP( WINDMN ) = MAX( WGAP(WINDMN),
$ W(WINDEX)-WERR(WINDEX)
$ - W(WINDMN)-WERR(WINDMN) )
ENDIF
IF( WINDEX.LT.WEND ) THEN
WGAP( WINDEX ) = MAX( SAVGAP,
$ W( WINDPL )-WERR( WINDPL )
$ - W( WINDEX )-WERR( WINDEX) )
ENDIF
ENDIF
IDONE = IDONE + 1
ENDIF
* here ends the code for the current child
*
139 CONTINUE
* Proceed to any remaining child nodes
NEWFST = J + 1
140 CONTINUE
150 CONTINUE
NDEPTH = NDEPTH + 1
GO TO 40
END IF
IBEGIN = IEND + 1
WBEGIN = WEND + 1
170 CONTINUE
*
RETURN
*
* End of DLARRV
*
END
SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD,
$ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
$ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
*
* -- LAPACK auxiliary routine (version 3.3.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* -- April 2011 --
*
* .. Scalar Arguments ..
LOGICAL WANTNC
INTEGER B1, BN, N, NEGCNT, R
DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
$ RQCORR, ZTZ
* ..
* .. Array Arguments ..
INTEGER ISUPPZ( * )
DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ),
$ WORK( * )
DOUBLE PRECISION Z( * )
* ..
*
* Purpose
* =======
*
* DLAR1V computes the (scaled) r-th column of the inverse of
* the sumbmatrix in rows B1 through BN of the tridiagonal matrix
* L D L**T - sigma I. When sigma is close to an eigenvalue, the
* computed vector is an accurate eigenvector. Usually, r corresponds
* to the index where the eigenvector is largest in magnitude.
* The following steps accomplish this computation :
* (a) Stationary qd transform, L D L**T - sigma I = L(+) D(+) L(+)**T,
* (b) Progressive qd transform, L D L**T - sigma I = U(-) D(-) U(-)**T,
* (c) Computation of the diagonal elements of the inverse of
* L D L**T - sigma I by combining the above transforms, and choosing
* r as the index where the diagonal of the inverse is (one of the)
* largest in magnitude.
* (d) Computation of the (scaled) r-th column of the inverse using the
* twisted factorization obtained by combining the top part of the
* the stationary and the bottom part of the progressive transform.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix L D L**T.
*
* B1 (input) INTEGER
* First index of the submatrix of L D L**T.
*
* BN (input) INTEGER
* Last index of the submatrix of L D L**T.
*
* LAMBDA (input) DOUBLE PRECISION
* The shift. In order to compute an accurate eigenvector,
* LAMBDA should be a good approximation to an eigenvalue
* of L D L**T.
*
* L (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) subdiagonal elements of the unit bidiagonal matrix
* L, in elements 1 to N-1.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The n diagonal elements of the diagonal matrix D.
*
* LD (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 elements L(i)*D(i).
*
* LLD (input) DOUBLE PRECISION array, dimension (N-1)
* The n-1 elements L(i)*L(i)*D(i).
*
* PIVMIN (input) DOUBLE PRECISION
* The minimum pivot in the Sturm sequence.
*
* GAPTOL (input) DOUBLE PRECISION
* Tolerance that indicates when eigenvector entries are negligible
* w.r.t. their contribution to the residual.
*
* Z (input/output) DOUBLE PRECISION array, dimension (N)
* On input, all entries of Z must be set to 0.
* On output, Z contains the (scaled) r-th column of the
* inverse. The scaling is such that Z(R) equals 1.
*
* WANTNC (input) LOGICAL
* Specifies whether NEGCNT has to be computed.
*
* NEGCNT (output) INTEGER
* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
* in the matrix factorization L D L**T, and NEGCNT = -1 otherwise.
*
* ZTZ (output) DOUBLE PRECISION
* The square of the 2-norm of Z.
*
* MINGMA (output) DOUBLE PRECISION
* The reciprocal of the largest (in magnitude) diagonal
* element of the inverse of L D L**T - sigma I.
*
* R (input/output) INTEGER
* The twist index for the twisted factorization used to
* compute Z.
* On input, 0 <= R <= N. If R is input as 0, R is set to
* the index where (L D L**T - sigma I)^{-1} is largest
* in magnitude. If 1 <= R <= N, R is unchanged.
* On output, R contains the twist index used to compute Z.
* Ideally, R designates the position of the maximum entry in the
* eigenvector.
*
* ISUPPZ (output) INTEGER array, dimension (2)
* The support of the vector in Z, i.e., the vector Z is
* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
*
* NRMINV (output) DOUBLE PRECISION
* NRMINV = 1/SQRT( ZTZ )
*
* RESID (output) DOUBLE PRECISION
* The residual of the FP vector.
* RESID = ABS( MINGMA )/SQRT( ZTZ )
*
* RQCORR (output) DOUBLE PRECISION
* The Rayleigh Quotient correction to LAMBDA.
* RQCORR = MINGMA*TMP
*
* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
*
* Further Details
* ===============
*
* Based on contributions by
* Beresford Parlett, University of California, Berkeley, USA
* Jim Demmel, University of California, Berkeley, USA
* Inderjit Dhillon, University of Texas, Austin, USA
* Osni Marques, LBNL/NERSC, USA
* Christof Voemel, University of California, Berkeley, USA
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL SAWNAN1, SAWNAN2
INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
$ R2
DOUBLE PRECISION DMINUS, DPLUS, EPS, S, TMP
* ..
* .. External Functions ..
LOGICAL DISNAN
DOUBLE PRECISION DLAMCH
EXTERNAL DISNAN, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
EPS = DLAMCH( 'Precision' )
IF( R.EQ.0 ) THEN
R1 = B1
R2 = BN
ELSE
R1 = R
R2 = R
END IF
* Storage for LPLUS
INDLPL = 0
* Storage for UMINUS
INDUMN = N
INDS = 2*N + 1
INDP = 3*N + 1
IF( B1.EQ.1 ) THEN
WORK( INDS ) = ZERO
ELSE
WORK( INDS+B1-1 ) = LLD( B1-1 )
END IF
*
* Compute the stationary transform (using the differential form)
* until the index R2.
*
SAWNAN1 = .FALSE.
NEG1 = 0
S = WORK( INDS+B1-1 ) - LAMBDA
DO 50 I = B1, R1 - 1
DPLUS = D( I ) + S
WORK( INDLPL+I ) = LD( I ) / DPLUS
IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
S = WORK( INDS+I ) - LAMBDA
50 CONTINUE
SAWNAN1 = DISNAN( S )
IF( SAWNAN1 ) GOTO 60
DO 51 I = R1, R2 - 1
DPLUS = D( I ) + S
WORK( INDLPL+I ) = LD( I ) / DPLUS
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
S = WORK( INDS+I ) - LAMBDA
51 CONTINUE
SAWNAN1 = DISNAN( S )
*
60 CONTINUE
IF( SAWNAN1 ) THEN
* Runs a slower version of the above loop if a NaN is detected
NEG1 = 0
S = WORK( INDS+B1-1 ) - LAMBDA
DO 70 I = B1, R1 - 1
DPLUS = D( I ) + S
IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
WORK( INDLPL+I ) = LD( I ) / DPLUS
IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
IF( WORK( INDLPL+I ).EQ.ZERO )
$ WORK( INDS+I ) = LLD( I )
S = WORK( INDS+I ) - LAMBDA
70 CONTINUE
DO 71 I = R1, R2 - 1
DPLUS = D( I ) + S
IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
WORK( INDLPL+I ) = LD( I ) / DPLUS
WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
IF( WORK( INDLPL+I ).EQ.ZERO )
$ WORK( INDS+I ) = LLD( I )
S = WORK( INDS+I ) - LAMBDA
71 CONTINUE
END IF
*
* Compute the progressive transform (using the differential form)
* until the index R1
*
SAWNAN2 = .FALSE.
NEG2 = 0
WORK( INDP+BN-1 ) = D( BN ) - LAMBDA
DO 80 I = BN - 1, R1, -1
DMINUS = LLD( I ) + WORK( INDP+I )
TMP = D( I ) / DMINUS
IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
WORK( INDUMN+I ) = L( I )*TMP
WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
80 CONTINUE
TMP = WORK( INDP+R1-1 )
SAWNAN2 = DISNAN( TMP )
IF( SAWNAN2 ) THEN
* Runs a slower version of the above loop if a NaN is detected
NEG2 = 0
DO 100 I = BN-1, R1, -1
DMINUS = LLD( I ) + WORK( INDP+I )
IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN
TMP = D( I ) / DMINUS
IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
WORK( INDUMN+I ) = L( I )*TMP
WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
IF( TMP.EQ.ZERO )
$ WORK( INDP+I-1 ) = D( I ) - LAMBDA
100 CONTINUE
END IF
*
* Find the index (from R1 to R2) of the largest (in magnitude)
* diagonal element of the inverse
*
MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1
IF( WANTNC ) THEN
NEGCNT = NEG1 + NEG2
ELSE
NEGCNT = -1
ENDIF
IF( ABS(MINGMA).EQ.ZERO )
$ MINGMA = EPS*WORK( INDS+R1-1 )
R = R1
DO 110 I = R1, R2 - 1
TMP = WORK( INDS+I ) + WORK( INDP+I )
IF( TMP.EQ.ZERO )
$ TMP = EPS*WORK( INDS+I )
IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN
MINGMA = TMP
R = I + 1
END IF
110 CONTINUE
*
* Compute the FP vector: solve N^T v = e_r
*
ISUPPZ( 1 ) = B1
ISUPPZ( 2 ) = BN
Z( R ) = ONE
ZTZ = ONE
*
* Compute the FP vector upwards from R
*
IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
DO 210 I = R-1, B1, -1
Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I ) = ZERO
ISUPPZ( 1 ) = I + 1
GOTO 220
ENDIF
ZTZ = ZTZ + Z( I )*Z( I )
210 CONTINUE
220 CONTINUE
ELSE
* Run slower loop if NaN occurred.
DO 230 I = R - 1, B1, -1
IF( Z( I+1 ).EQ.ZERO ) THEN
Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
ELSE
Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
END IF
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I ) = ZERO
ISUPPZ( 1 ) = I + 1
GO TO 240
END IF
ZTZ = ZTZ + Z( I )*Z( I )
230 CONTINUE
240 CONTINUE
ENDIF
* Compute the FP vector downwards from R in blocks of size BLKSIZ
IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
DO 250 I = R, BN-1
Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I+1 ) = ZERO
ISUPPZ( 2 ) = I
GO TO 260
END IF
ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
250 CONTINUE
260 CONTINUE
ELSE
* Run slower loop if NaN occurred.
DO 270 I = R, BN - 1
IF( Z( I ).EQ.ZERO ) THEN
Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
ELSE
Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
END IF
IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
$ THEN
Z( I+1 ) = ZERO
ISUPPZ( 2 ) = I
GO TO 280
END IF
ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
270 CONTINUE
280 CONTINUE
END IF
*
* Compute quantities for convergence test
*
TMP = ONE / ZTZ
NRMINV = SQRT( TMP )
RESID = ABS( MINGMA )*NRMINV
RQCORR = MINGMA*TMP
*
*
RETURN
*
* End of DLAR1V
*
END
*> \brief ZHBEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHBEV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
* RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, UPLO
* INTEGER INFO, KD, LDAB, LDZ, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * ), W( * )
* COMPLEX*16 AB( LDAB, * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHBEV computes all the eigenvalues and, optionally, eigenvectors of
*> a complex Hermitian band matrix A.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBZ
*> \verbatim
*> JOBZ is CHARACTER*1
*> = 'N': Compute eigenvalues only;
*> = 'V': Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] KD
*> \verbatim
*> KD is INTEGER
*> The number of superdiagonals of the matrix A if UPLO = 'U',
*> or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB, N)
*> On entry, the upper or lower triangle of the Hermitian band
*> matrix A, stored in the first KD+1 rows of the array. The
*> j-th column of A is stored in the j-th column of the array AB
*> as follows:
*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*>
*> On exit, AB is overwritten by values generated during the
*> reduction to tridiagonal form. If UPLO = 'U', the first
*> superdiagonal and the diagonal of the tridiagonal matrix T
*> are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
*> the diagonal and first subdiagonal of T are returned in the
*> first two rows of AB.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= KD + 1.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> If INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ, N)
*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
*> eigenvectors of the matrix A, with the i-th column of Z
*> holding the eigenvector associated with W(i).
*> If JOBZ = 'N', then Z is not referenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1, and if
*> JOBZ = 'V', LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (max(1,3*N-2))
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> > 0: if INFO = i, the algorithm failed to converge; i
*> off-diagonal elements of an intermediate tridiagonal
*> form did not converge to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHEReigen
*
* =====================================================================
SUBROUTINE ZHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
$ RWORK, INFO )
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, KD, LDAB, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 AB( LDAB, * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, WANTZ
INTEGER IINFO, IMAX, INDE, INDRWK, ISCALE
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANHB
EXTERNAL LSAME, DLAMCH, ZLANHB
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSTERF, XERBLA, ZHBTRD, ZLASCL, ZSTEQR
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KD.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -6
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -9
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHBEV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( LOWER ) THEN
W( 1 ) = AB( 1, 1 )
ELSE
W( 1 ) = AB( KD+1, 1 )
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 = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = ZLANHB( 'M', UPLO, N, KD, AB, LDAB, RWORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
CALL ZLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
ELSE
CALL ZLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
END IF
END IF
*
* Call ZHBTRD to reduce Hermitian band matrix to tridiagonal form.
*
INDE = 1
CALL ZHBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, RWORK( INDE ), Z,
$ LDZ, WORK, IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, call ZSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, RWORK( INDE ), INFO )
ELSE
INDRWK = INDE + N
CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ,
$ RWORK( INDRWK ), INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
RETURN
*
* End of ZHBEV
*
END
*> \brief \b ZHBTRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHBTRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ,
* WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO, VECT
* INTEGER INFO, KD, LDAB, LDQ, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 AB( LDAB, * ), Q( LDQ, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHBTRD reduces a complex Hermitian band matrix A to real symmetric
*> tridiagonal form T by a unitary similarity transformation:
*> Q**H * A * Q = T.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] VECT
*> \verbatim
*> VECT is CHARACTER*1
*> = 'N': do not form Q;
*> = 'V': form Q;
*> = 'U': update a matrix X, by forming X*Q.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] KD
*> \verbatim
*> KD is INTEGER
*> The number of superdiagonals of the matrix A if UPLO = 'U',
*> or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> On entry, the upper or lower triangle of the Hermitian band
*> matrix A, stored in the first KD+1 rows of the array. The
*> j-th column of A is stored in the j-th column of the array AB
*> as follows:
*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*> On exit, the diagonal elements of AB are overwritten by the
*> diagonal elements of the tridiagonal matrix T; if KD > 0, the
*> elements on the first superdiagonal (if UPLO = 'U') or the
*> first subdiagonal (if UPLO = 'L') are overwritten by the
*> off-diagonal elements of T; the rest of AB is overwritten by
*> values generated during the reduction.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= KD+1.
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The diagonal elements of the tridiagonal matrix T.
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> The off-diagonal elements of the tridiagonal matrix T:
*> E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> On entry, if VECT = 'U', then Q must contain an N-by-N
*> matrix X; if VECT = 'N' or 'V', then Q need not be set.
*>
*> On exit:
*> if VECT = 'V', Q contains the N-by-N unitary matrix Q;
*> if VECT = 'U', Q contains the product X*Q;
*> if VECT = 'N', the array Q is not referenced.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q.
*> LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Modified by Linda Kaufman, Bell Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ,
$ WORK, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER UPLO, VECT
INTEGER INFO, KD, LDAB, LDQ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 AB( LDAB, * ), Q( LDQ, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL INITQ, UPPER, WANTQ
INTEGER I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
$ J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1,
$ KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
DOUBLE PRECISION ABST
COMPLEX*16 T, TEMP
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLAR2V, ZLARGV, ZLARTG, ZLARTV,
$ ZLASET, ZROT, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCONJG, MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INITQ = LSAME( VECT, 'V' )
WANTQ = INITQ .OR. LSAME( VECT, 'U' )
UPPER = LSAME( UPLO, 'U' )
KD1 = KD + 1
KDM1 = KD - 1
INCX = LDAB - 1
IQEND = 1
*
INFO = 0
IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KD.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KD1 ) THEN
INFO = -6
ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHBTRD', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Initialize Q to the unit matrix, if needed
*
IF( INITQ )
$ CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
*
* Wherever possible, plane rotations are generated and applied in
* vector operations of length NR over the index set J1:J2:KD1.
*
* The real cosines and complex sines of the plane rotations are
* stored in the arrays D and WORK.
*
INCA = KD1*LDAB
KDN = MIN( N-1, KD )
IF( UPPER ) THEN
*
IF( KD.GT.1 ) THEN
*
* Reduce to complex Hermitian tridiagonal form, working with
* the upper triangle
*
NR = 0
J1 = KDN + 2
J2 = 1
*
AB( KD1, 1 ) = DBLE( AB( KD1, 1 ) )
DO 90 I = 1, N - 2
*
* Reduce i-th row of matrix to tridiagonal form
*
DO 80 K = KDN + 1, 2, -1
J1 = J1 + KDN
J2 = J2 + KDN
*
IF( NR.GT.0 ) THEN
*
* generate plane rotations to annihilate nonzero
* elements which have been created outside the band
*
CALL ZLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ),
$ KD1, D( J1 ), KD1 )
*
* apply rotations from the right
*
*
* Dependent on the the number of diagonals either
* ZLARTV or ZROT is used
*
IF( NR.GE.2*KD-1 ) THEN
DO 10 L = 1, KD - 1
CALL ZLARTV( NR, AB( L+1, J1-1 ), INCA,
$ AB( L, J1 ), INCA, D( J1 ),
$ WORK( J1 ), KD1 )
10 CONTINUE
*
ELSE
JEND = J1 + ( NR-1 )*KD1
DO 20 JINC = J1, JEND, KD1
CALL ZROT( KDM1, AB( 2, JINC-1 ), 1,
$ AB( 1, JINC ), 1, D( JINC ),
$ WORK( JINC ) )
20 CONTINUE
END IF
END IF
*
*
IF( K.GT.2 ) THEN
IF( K.LE.N-I+1 ) THEN
*
* generate plane rotation to annihilate a(i,i+k-1)
* within the band
*
CALL ZLARTG( AB( KD-K+3, I+K-2 ),
$ AB( KD-K+2, I+K-1 ), D( I+K-1 ),
$ WORK( I+K-1 ), TEMP )
AB( KD-K+3, I+K-2 ) = TEMP
*
* apply rotation from the right
*
CALL ZROT( K-3, AB( KD-K+4, I+K-2 ), 1,
$ AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ),
$ WORK( I+K-1 ) )
END IF
NR = NR + 1
J1 = J1 - KDN - 1
END IF
*
* apply plane rotations from both sides to diagonal
* blocks
*
IF( NR.GT.0 )
$ CALL ZLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ),
$ AB( KD, J1 ), INCA, D( J1 ),
$ WORK( J1 ), KD1 )
*
* apply plane rotations from the left
*
IF( NR.GT.0 ) THEN
CALL ZLACGV( NR, WORK( J1 ), KD1 )
IF( 2*KD-1.LT.NR ) THEN
*
* Dependent on the the number of diagonals either
* ZLARTV or ZROT is used
*
DO 30 L = 1, KD - 1
IF( J2+L.GT.N ) THEN
NRT = NR - 1
ELSE
NRT = NR
END IF
IF( NRT.GT.0 )
$ CALL ZLARTV( NRT, AB( KD-L, J1+L ), INCA,
$ AB( KD-L+1, J1+L ), INCA,
$ D( J1 ), WORK( J1 ), KD1 )
30 CONTINUE
ELSE
J1END = J1 + KD1*( NR-2 )
IF( J1END.GE.J1 ) THEN
DO 40 JIN = J1, J1END, KD1
CALL ZROT( KD-1, AB( KD-1, JIN+1 ), INCX,
$ AB( KD, JIN+1 ), INCX,
$ D( JIN ), WORK( JIN ) )
40 CONTINUE
END IF
LEND = MIN( KDM1, N-J2 )
LAST = J1END + KD1
IF( LEND.GT.0 )
$ CALL ZROT( LEND, AB( KD-1, LAST+1 ), INCX,
$ AB( KD, LAST+1 ), INCX, D( LAST ),
$ WORK( LAST ) )
END IF
END IF
*
IF( WANTQ ) THEN
*
* accumulate product of plane rotations in Q
*
IF( INITQ ) THEN
*
* take advantage of the fact that Q was
* initially the Identity matrix
*
IQEND = MAX( IQEND, J2 )
I2 = MAX( 0, K-3 )
IQAEND = 1 + I*KD
IF( K.EQ.2 )
$ IQAEND = IQAEND + KD
IQAEND = MIN( IQAEND, IQEND )
DO 50 J = J1, J2, KD1
IBL = I - I2 / KDM1
I2 = I2 + 1
IQB = MAX( 1, J-IBL )
NQ = 1 + IQAEND - IQB
IQAEND = MIN( IQAEND+KD, IQEND )
CALL ZROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
$ 1, D( J ), DCONJG( WORK( J ) ) )
50 CONTINUE
ELSE
*
DO 60 J = J1, J2, KD1
CALL ZROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
$ D( J ), DCONJG( WORK( J ) ) )
60 CONTINUE
END IF
*
END IF
*
IF( J2+KDN.GT.N ) THEN
*
* adjust J2 to keep within the bounds of the matrix
*
NR = NR - 1
J2 = J2 - KDN - 1
END IF
*
DO 70 J = J1, J2, KD1
*
* create nonzero element a(j-1,j+kd) outside the band
* and store it in WORK
*
WORK( J+KD ) = WORK( J )*AB( 1, J+KD )
AB( 1, J+KD ) = D( J )*AB( 1, J+KD )
70 CONTINUE
80 CONTINUE
90 CONTINUE
END IF
*
IF( KD.GT.0 ) THEN
*
* make off-diagonal elements real and copy them to E
*
DO 100 I = 1, N - 1
T = AB( KD, I+1 )
ABST = ABS( T )
AB( KD, I+1 ) = ABST
E( I ) = ABST
IF( ABST.NE.ZERO ) THEN
T = T / ABST
ELSE
T = CONE
END IF
IF( I.LT.N-1 )
$ AB( KD, I+2 ) = AB( KD, I+2 )*T
IF( WANTQ ) THEN
CALL ZSCAL( N, DCONJG( T ), Q( 1, I+1 ), 1 )
END IF
100 CONTINUE
ELSE
*
* set E to zero if original matrix was diagonal
*
DO 110 I = 1, N - 1
E( I ) = ZERO
110 CONTINUE
END IF
*
* copy diagonal elements to D
*
DO 120 I = 1, N
D( I ) = AB( KD1, I )
120 CONTINUE
*
ELSE
*
IF( KD.GT.1 ) THEN
*
* Reduce to complex Hermitian tridiagonal form, working with
* the lower triangle
*
NR = 0
J1 = KDN + 2
J2 = 1
*
AB( 1, 1 ) = DBLE( AB( 1, 1 ) )
DO 210 I = 1, N - 2
*
* Reduce i-th column of matrix to tridiagonal form
*
DO 200 K = KDN + 1, 2, -1
J1 = J1 + KDN
J2 = J2 + KDN
*
IF( NR.GT.0 ) THEN
*
* generate plane rotations to annihilate nonzero
* elements which have been created outside the band
*
CALL ZLARGV( NR, AB( KD1, J1-KD1 ), INCA,
$ WORK( J1 ), KD1, D( J1 ), KD1 )
*
* apply plane rotations from one side
*
*
* Dependent on the the number of diagonals either
* ZLARTV or ZROT is used
*
IF( NR.GT.2*KD-1 ) THEN
DO 130 L = 1, KD - 1
CALL ZLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA,
$ AB( KD1-L+1, J1-KD1+L ), INCA,
$ D( J1 ), WORK( J1 ), KD1 )
130 CONTINUE
ELSE
JEND = J1 + KD1*( NR-1 )
DO 140 JINC = J1, JEND, KD1
CALL ZROT( KDM1, AB( KD, JINC-KD ), INCX,
$ AB( KD1, JINC-KD ), INCX,
$ D( JINC ), WORK( JINC ) )
140 CONTINUE
END IF
*
END IF
*
IF( K.GT.2 ) THEN
IF( K.LE.N-I+1 ) THEN
*
* generate plane rotation to annihilate a(i+k-1,i)
* within the band
*
CALL ZLARTG( AB( K-1, I ), AB( K, I ),
$ D( I+K-1 ), WORK( I+K-1 ), TEMP )
AB( K-1, I ) = TEMP
*
* apply rotation from the left
*
CALL ZROT( K-3, AB( K-2, I+1 ), LDAB-1,
$ AB( K-1, I+1 ), LDAB-1, D( I+K-1 ),
$ WORK( I+K-1 ) )
END IF
NR = NR + 1
J1 = J1 - KDN - 1
END IF
*
* apply plane rotations from both sides to diagonal
* blocks
*
IF( NR.GT.0 )
$ CALL ZLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ),
$ AB( 2, J1-1 ), INCA, D( J1 ),
$ WORK( J1 ), KD1 )
*
* apply plane rotations from the right
*
*
* Dependent on the the number of diagonals either
* ZLARTV or ZROT is used
*
IF( NR.GT.0 ) THEN
CALL ZLACGV( NR, WORK( J1 ), KD1 )
IF( NR.GT.2*KD-1 ) THEN
DO 150 L = 1, KD - 1
IF( J2+L.GT.N ) THEN
NRT = NR - 1
ELSE
NRT = NR
END IF
IF( NRT.GT.0 )
$ CALL ZLARTV( NRT, AB( L+2, J1-1 ), INCA,
$ AB( L+1, J1 ), INCA, D( J1 ),
$ WORK( J1 ), KD1 )
150 CONTINUE
ELSE
J1END = J1 + KD1*( NR-2 )
IF( J1END.GE.J1 ) THEN
DO 160 J1INC = J1, J1END, KD1
CALL ZROT( KDM1, AB( 3, J1INC-1 ), 1,
$ AB( 2, J1INC ), 1, D( J1INC ),
$ WORK( J1INC ) )
160 CONTINUE
END IF
LEND = MIN( KDM1, N-J2 )
LAST = J1END + KD1
IF( LEND.GT.0 )
$ CALL ZROT( LEND, AB( 3, LAST-1 ), 1,
$ AB( 2, LAST ), 1, D( LAST ),
$ WORK( LAST ) )
END IF
END IF
*
*
*
IF( WANTQ ) THEN
*
* accumulate product of plane rotations in Q
*
IF( INITQ ) THEN
*
* take advantage of the fact that Q was
* initially the Identity matrix
*
IQEND = MAX( IQEND, J2 )
I2 = MAX( 0, K-3 )
IQAEND = 1 + I*KD
IF( K.EQ.2 )
$ IQAEND = IQAEND + KD
IQAEND = MIN( IQAEND, IQEND )
DO 170 J = J1, J2, KD1
IBL = I - I2 / KDM1
I2 = I2 + 1
IQB = MAX( 1, J-IBL )
NQ = 1 + IQAEND - IQB
IQAEND = MIN( IQAEND+KD, IQEND )
CALL ZROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
$ 1, D( J ), WORK( J ) )
170 CONTINUE
ELSE
*
DO 180 J = J1, J2, KD1
CALL ZROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
$ D( J ), WORK( J ) )
180 CONTINUE
END IF
END IF
*
IF( J2+KDN.GT.N ) THEN
*
* adjust J2 to keep within the bounds of the matrix
*
NR = NR - 1
J2 = J2 - KDN - 1
END IF
*
DO 190 J = J1, J2, KD1
*
* create nonzero element a(j+kd,j-1) outside the
* band and store it in WORK
*
WORK( J+KD ) = WORK( J )*AB( KD1, J )
AB( KD1, J ) = D( J )*AB( KD1, J )
190 CONTINUE
200 CONTINUE
210 CONTINUE
END IF
*
IF( KD.GT.0 ) THEN
*
* make off-diagonal elements real and copy them to E
*
DO 220 I = 1, N - 1
T = AB( 2, I )
ABST = ABS( T )
AB( 2, I ) = ABST
E( I ) = ABST
IF( ABST.NE.ZERO ) THEN
T = T / ABST
ELSE
T = CONE
END IF
IF( I.LT.N-1 )
$ AB( 2, I+1 ) = AB( 2, I+1 )*T
IF( WANTQ ) THEN
CALL ZSCAL( N, T, Q( 1, I+1 ), 1 )
END IF
220 CONTINUE
ELSE
*
* set E to zero if original matrix was diagonal
*
DO 230 I = 1, N - 1
E( I ) = ZERO
230 CONTINUE
END IF
*
* copy diagonal elements to D
*
DO 240 I = 1, N
D( I ) = AB( 1, I )
240 CONTINUE
END IF
*
RETURN
*
* End of ZHBTRD
*
END
*> \brief \b ZLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a Hermitian band matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANHB + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB,
* WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM, UPLO
* INTEGER K, LDAB, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 AB( LDAB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANHB returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of an
*> n by n hermitian band matrix A, with k super-diagonals.
*> \endverbatim
*>
*> \return ZLANHB
*> \verbatim
*>
*> ZLANHB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*> (
*> ( norm1(A), NORM = '1', 'O' or 'o'
*> (
*> ( normI(A), NORM = 'I' or 'i'
*> (
*> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*>
*> where norm1 denotes the one norm of a matrix (maximum column sum),
*> normI denotes the infinity norm of a matrix (maximum row sum) and
*> normF denotes the Frobenius norm of a matrix (square root of sum of
*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] NORM
*> \verbatim
*> NORM is CHARACTER*1
*> Specifies the value to be returned in ZLANHB as described
*> above.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> band matrix A is supplied.
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, ZLANHB is
*> set to zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of super-diagonals or sub-diagonals of the
*> band matrix A. K >= 0.
*> \endverbatim
*>
*> \param[in] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> The upper or lower triangle of the hermitian band matrix A,
*> stored in the first K+1 rows of AB. The j-th column of A is
*> stored in the j-th column of the array AB as follows:
*> if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).
*> Note that the imaginary parts of the diagonal elements need
*> not be set and are assumed to be zero.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= K+1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
*> WORK is not referenced.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB,
$ WORK )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER K, LDAB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 AB( LDAB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = MAX( K+2-J, 1 ), K
SUM = ABS( AB( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
SUM = ABS( DBLE( AB( K+1, J ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
20 CONTINUE
ELSE
DO 40 J = 1, N
SUM = ABS( DBLE( AB( 1, J ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
DO 30 I = 2, MIN( N+1-J, K+1 )
SUM = ABS( AB( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is hermitian).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
L = K + 1 - J
DO 50 I = MAX( 1, J-K ), J - 1
ABSA = ABS( AB( L+I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
50 CONTINUE
WORK( J ) = SUM + ABS( DBLE( AB( K+1, J ) ) )
60 CONTINUE
DO 70 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( DBLE( AB( 1, J ) ) )
L = 1 - J
DO 90 I = J + 1, MIN( N, J+K )
ABSA = ABS( AB( L+I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
90 CONTINUE
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( K.GT.0 ) THEN
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL ZLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ),
$ 1, SCALE, SUM )
110 CONTINUE
L = K + 1
ELSE
DO 120 J = 1, N - 1
CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
$ SUM )
120 CONTINUE
L = 1
END IF
SUM = 2*SUM
ELSE
L = 1
END IF
DO 130 J = 1, N
IF( DBLE( AB( L, J ) ).NE.ZERO ) THEN
ABSA = ABS( DBLE( AB( L, J ) ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
130 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANHB = VALUE
RETURN
*
* End of ZLANHB
*
END
*> \brief \b ZLAR2V applies a vector of plane rotations with real cosines and complex sines from both sides to a sequence of 2-by-2 symmetric/Hermitian matrices.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAR2V + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAR2V( N, X, Y, Z, INCX, C, S, INCC )
*
* .. Scalar Arguments ..
* INTEGER INCC, INCX, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( * )
* COMPLEX*16 S( * ), X( * ), Y( * ), Z( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAR2V applies a vector of complex plane rotations with real cosines
*> from both sides to a sequence of 2-by-2 complex Hermitian matrices,
*> defined by the elements of the vectors x, y and z. For i = 1,2,...,n
*>
*> ( x(i) z(i) ) :=
*> ( conjg(z(i)) y(i) )
*>
*> ( c(i) conjg(s(i)) ) ( x(i) z(i) ) ( c(i) -conjg(s(i)) )
*> ( -s(i) c(i) ) ( conjg(z(i)) y(i) ) ( s(i) c(i) )
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of plane rotations to be applied.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (1+(N-1)*INCX)
*> The vector x; the elements of x are assumed to be real.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX*16 array, dimension (1+(N-1)*INCX)
*> The vector y; the elements of y are assumed to be real.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (1+(N-1)*INCX)
*> The vector z.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between elements of X, Y and Z. INCX > 0.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
*> The cosines of the plane rotations.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is COMPLEX*16 array, dimension (1+(N-1)*INCC)
*> The sines of the plane rotations.
*> \endverbatim
*>
*> \param[in] INCC
*> \verbatim
*> INCC is INTEGER
*> The increment between elements of C and S. INCC > 0.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLAR2V( N, X, Y, Z, INCX, C, S, INCC )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER INCC, INCX, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * )
COMPLEX*16 S( * ), X( * ), Y( * ), Z( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IC, IX
DOUBLE PRECISION CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,
$ ZIR
COMPLEX*16 SI, T2, T3, T4, ZI
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG
* ..
* .. Executable Statements ..
*
IX = 1
IC = 1
DO 10 I = 1, N
XI = DBLE( X( IX ) )
YI = DBLE( Y( IX ) )
ZI = Z( IX )
ZIR = DBLE( ZI )
ZII = DIMAG( ZI )
CI = C( IC )
SI = S( IC )
SIR = DBLE( SI )
SII = DIMAG( SI )
T1R = SIR*ZIR - SII*ZII
T1I = SIR*ZII + SII*ZIR
T2 = CI*ZI
T3 = T2 - DCONJG( SI )*XI
T4 = DCONJG( T2 ) + SI*YI
T5 = CI*XI + T1R
T6 = CI*YI - T1R
X( IX ) = CI*T5 + ( SIR*DBLE( T4 )+SII*DIMAG( T4 ) )
Y( IX ) = CI*T6 - ( SIR*DBLE( T3 )-SII*DIMAG( T3 ) )
Z( IX ) = CI*T3 + DCONJG( SI )*DCMPLX( T6, T1I )
IX = IX + INCX
IC = IC + INCC
10 CONTINUE
RETURN
*
* End of ZLAR2V
*
END
*> \brief \b ZLARGV generates a vector of plane rotations with real cosines and complex sines.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARGV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARGV( N, X, INCX, Y, INCY, C, INCC )
*
* .. Scalar Arguments ..
* INTEGER INCC, INCX, INCY, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( * )
* COMPLEX*16 X( * ), Y( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARGV generates a vector of complex plane rotations with real
*> cosines, determined by elements of the complex vectors x and y.
*> For i = 1,2,...,n
*>
*> ( c(i) s(i) ) ( x(i) ) = ( r(i) )
*> ( -conjg(s(i)) c(i) ) ( y(i) ) = ( 0 )
*>
*> where c(i)**2 + ABS(s(i))**2 = 1
*>
*> The following conventions are used (these are the same as in ZLARTG,
*> but differ from the BLAS1 routine ZROTG):
*> If y(i)=0, then c(i)=1 and s(i)=0.
*> If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of plane rotations to be generated.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (1+(N-1)*INCX)
*> On entry, the vector x.
*> On exit, x(i) is overwritten by r(i), for i = 1,...,n.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between elements of X. INCX > 0.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX*16 array, dimension (1+(N-1)*INCY)
*> On entry, the vector y.
*> On exit, the sines of the plane rotations.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> The increment between elements of Y. INCY > 0.
*> \endverbatim
*>
*> \param[out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
*> The cosines of the plane rotations.
*> \endverbatim
*>
*> \param[in] INCC
*> \verbatim
*> INCC is INTEGER
*> The increment between elements of C. INCC > 0.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> 6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel
*>
*> This version has a few statements commented out for thread safety
*> (machine parameters are computed on each entry). 10 feb 03, SJH.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLARGV( N, X, INCX, Y, INCY, C, INCC )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER INCC, INCX, INCY, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * )
COMPLEX*16 X( * ), Y( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION TWO, ONE, ZERO
PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 )
COMPLEX*16 CZERO
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
* LOGICAL FIRST
INTEGER COUNT, I, IC, IX, IY, J
DOUBLE PRECISION CS, D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
$ SAFMN2, SAFMX2, SCALE
COMPLEX*16 F, FF, FS, G, GS, R, SN
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL DLAMCH, DLAPY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG,
$ MAX, SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION ABS1, ABSSQ
* ..
* .. Save statement ..
* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
* ..
* .. Data statements ..
* DATA FIRST / .TRUE. /
* ..
* .. Statement Function definitions ..
ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) )
ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2
* ..
* .. Executable Statements ..
*
* IF( FIRST ) THEN
* FIRST = .FALSE.
SAFMIN = DLAMCH( 'S' )
EPS = DLAMCH( 'E' )
SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
$ LOG( DLAMCH( 'B' ) ) / TWO )
SAFMX2 = ONE / SAFMN2
* END IF
IX = 1
IY = 1
IC = 1
DO 60 I = 1, N
F = X( IX )
G = Y( IY )
*
* Use identical algorithm as in ZLARTG
*
SCALE = MAX( ABS1( F ), ABS1( G ) )
FS = F
GS = G
COUNT = 0
IF( SCALE.GE.SAFMX2 ) THEN
10 CONTINUE
COUNT = COUNT + 1
FS = FS*SAFMN2
GS = GS*SAFMN2
SCALE = SCALE*SAFMN2
IF( SCALE.GE.SAFMX2 )
$ GO TO 10
ELSE IF( SCALE.LE.SAFMN2 ) THEN
IF( G.EQ.CZERO ) THEN
CS = ONE
SN = CZERO
R = F
GO TO 50
END IF
20 CONTINUE
COUNT = COUNT - 1
FS = FS*SAFMX2
GS = GS*SAFMX2
SCALE = SCALE*SAFMX2
IF( SCALE.LE.SAFMN2 )
$ GO TO 20
END IF
F2 = ABSSQ( FS )
G2 = ABSSQ( GS )
IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN
*
* This is a rare case: F is very small.
*
IF( F.EQ.CZERO ) THEN
CS = ZERO
R = DLAPY2( DBLE( G ), DIMAG( G ) )
* Do complex/real division explicitly with two real
* divisions
D = DLAPY2( DBLE( GS ), DIMAG( GS ) )
SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D )
GO TO 50
END IF
F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) )
* G2 and G2S are accurate
* G2 is at least SAFMIN, and G2S is at least SAFMN2
G2S = SQRT( G2 )
* Error in CS from underflow in F2S is at most
* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
* and so CS .lt. sqrt(SAFMIN)
* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
CS = F2S / G2S
* Make sure abs(FF) = 1
* Do complex/real division explicitly with 2 real divisions
IF( ABS1( F ).GT.ONE ) THEN
D = DLAPY2( DBLE( F ), DIMAG( F ) )
FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D )
ELSE
DR = SAFMX2*DBLE( F )
DI = SAFMX2*DIMAG( F )
D = DLAPY2( DR, DI )
FF = DCMPLX( DR / D, DI / D )
END IF
SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S )
R = CS*F + SN*G
ELSE
*
* This is the most common case.
* Neither F2 nor F2/G2 are less than SAFMIN
* F2S cannot overflow, and it is accurate
*
F2S = SQRT( ONE+G2 / F2 )
* Do the F2S(real)*FS(complex) multiply with two real
* multiplies
R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) )
CS = ONE / F2S
D = F2 + G2
* Do complex/real division explicitly with two real divisions
SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D )
SN = SN*DCONJG( GS )
IF( COUNT.NE.0 ) THEN
IF( COUNT.GT.0 ) THEN
DO 30 J = 1, COUNT
R = R*SAFMX2
30 CONTINUE
ELSE
DO 40 J = 1, -COUNT
R = R*SAFMN2
40 CONTINUE
END IF
END IF
END IF
50 CONTINUE
C( IC ) = CS
Y( IY ) = SN
X( IX ) = R
IC = IC + INCC
IY = IY + INCY
IX = IX + INCX
60 CONTINUE
RETURN
*
* End of ZLARGV
*
END
*> \brief \b ZLARTG generates a plane rotation with real cosine and complex sine.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARTG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARTG( F, G, CS, SN, R )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION CS
* COMPLEX*16 F, G, R, SN
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARTG generates a plane rotation so that
*>
*> [ CS SN ] [ F ] [ R ]
*> [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1.
*> [ -SN CS ] [ G ] [ 0 ]
*>
*> This is a faster version of the BLAS1 routine ZROTG, except for
*> the following differences:
*> F and G are unchanged on return.
*> If G=0, then CS=1 and SN=0.
*> If F=0, then CS=0 and SN is chosen so that R is real.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] F
*> \verbatim
*> F is COMPLEX*16
*> The first component of vector to be rotated.
*> \endverbatim
*>
*> \param[in] G
*> \verbatim
*> G is COMPLEX*16
*> The second component of vector to be rotated.
*> \endverbatim
*>
*> \param[out] CS
*> \verbatim
*> CS is DOUBLE PRECISION
*> The cosine of the rotation.
*> \endverbatim
*>
*> \param[out] SN
*> \verbatim
*> SN is COMPLEX*16
*> The sine of the rotation.
*> \endverbatim
*>
*> \param[out] R
*> \verbatim
*> R is COMPLEX*16
*> The nonzero component of the rotated vector.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel
*>
*> This version has a few statements commented out for thread safety
*> (machine parameters are computed on each entry). 10 feb 03, SJH.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLARTG( F, G, CS, SN, R )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION CS
COMPLEX*16 F, G, R, SN
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION TWO, ONE, ZERO
PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 )
COMPLEX*16 CZERO
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
* LOGICAL FIRST
INTEGER COUNT, I
DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
$ SAFMN2, SAFMX2, SCALE
COMPLEX*16 FF, FS, GS
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
LOGICAL DISNAN
EXTERNAL DLAMCH, DLAPY2, DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG,
$ MAX, SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION ABS1, ABSSQ
* ..
* .. Statement Function definitions ..
ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) )
ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2
* ..
* .. Executable Statements ..
*
SAFMIN = DLAMCH( 'S' )
EPS = DLAMCH( 'E' )
SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
$ LOG( DLAMCH( 'B' ) ) / TWO )
SAFMX2 = ONE / SAFMN2
SCALE = MAX( ABS1( F ), ABS1( G ) )
FS = F
GS = G
COUNT = 0
IF( SCALE.GE.SAFMX2 ) THEN
10 CONTINUE
COUNT = COUNT + 1
FS = FS*SAFMN2
GS = GS*SAFMN2
SCALE = SCALE*SAFMN2
IF( SCALE.GE.SAFMX2 )
$ GO TO 10
ELSE IF( SCALE.LE.SAFMN2 ) THEN
IF( G.EQ.CZERO.OR.DISNAN( ABS( G ) ) ) THEN
CS = ONE
SN = CZERO
R = F
RETURN
END IF
20 CONTINUE
COUNT = COUNT - 1
FS = FS*SAFMX2
GS = GS*SAFMX2
SCALE = SCALE*SAFMX2
IF( SCALE.LE.SAFMN2 )
$ GO TO 20
END IF
F2 = ABSSQ( FS )
G2 = ABSSQ( GS )
IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN
*
* This is a rare case: F is very small.
*
IF( F.EQ.CZERO ) THEN
CS = ZERO
R = DLAPY2( DBLE( G ), DIMAG( G ) )
* Do complex/real division explicitly with two real divisions
D = DLAPY2( DBLE( GS ), DIMAG( GS ) )
SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D )
RETURN
END IF
F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) )
* G2 and G2S are accurate
* G2 is at least SAFMIN, and G2S is at least SAFMN2
G2S = SQRT( G2 )
* Error in CS from underflow in F2S is at most
* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
* and so CS .lt. sqrt(SAFMIN)
* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
CS = F2S / G2S
* Make sure abs(FF) = 1
* Do complex/real division explicitly with 2 real divisions
IF( ABS1( F ).GT.ONE ) THEN
D = DLAPY2( DBLE( F ), DIMAG( F ) )
FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D )
ELSE
DR = SAFMX2*DBLE( F )
DI = SAFMX2*DIMAG( F )
D = DLAPY2( DR, DI )
FF = DCMPLX( DR / D, DI / D )
END IF
SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S )
R = CS*F + SN*G
ELSE
*
* This is the most common case.
* Neither F2 nor F2/G2 are less than SAFMIN
* F2S cannot overflow, and it is accurate
*
F2S = SQRT( ONE+G2 / F2 )
* Do the F2S(real)*FS(complex) multiply with two real multiplies
R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) )
CS = ONE / F2S
D = F2 + G2
* Do complex/real division explicitly with two real divisions
SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D )
SN = SN*DCONJG( GS )
IF( COUNT.NE.0 ) THEN
IF( COUNT.GT.0 ) THEN
DO 30 I = 1, COUNT
R = R*SAFMX2
30 CONTINUE
ELSE
DO 40 I = 1, -COUNT
R = R*SAFMN2
40 CONTINUE
END IF
END IF
END IF
RETURN
*
* End of ZLARTG
*
END
*> \brief \b ZLARTV applies a vector of plane rotations with real cosines and complex sines to the elements of a pair of vectors.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARTV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARTV( N, X, INCX, Y, INCY, C, S, INCC )
*
* .. Scalar Arguments ..
* INTEGER INCC, INCX, INCY, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( * )
* COMPLEX*16 S( * ), X( * ), Y( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARTV applies a vector of complex plane rotations with real cosines
*> to elements of the complex vectors x and y. For i = 1,2,...,n
*>
*> ( x(i) ) := ( c(i) s(i) ) ( x(i) )
*> ( y(i) ) ( -conjg(s(i)) c(i) ) ( y(i) )
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of plane rotations to be applied.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (1+(N-1)*INCX)
*> The vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between elements of X. INCX > 0.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX*16 array, dimension (1+(N-1)*INCY)
*> The vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> The increment between elements of Y. INCY > 0.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
*> The cosines of the plane rotations.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is COMPLEX*16 array, dimension (1+(N-1)*INCC)
*> The sines of the plane rotations.
*> \endverbatim
*>
*> \param[in] INCC
*> \verbatim
*> INCC is INTEGER
*> The increment between elements of C and S. INCC > 0.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLARTV( N, X, INCX, Y, INCY, C, S, INCC )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER INCC, INCX, INCY, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * )
COMPLEX*16 S( * ), X( * ), Y( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IC, IX, IY
COMPLEX*16 XI, YI
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
IX = 1
IY = 1
IC = 1
DO 10 I = 1, N
XI = X( IX )
YI = Y( IY )
X( IX ) = C( IC )*XI + S( IC )*YI
Y( IY ) = C( IC )*YI - DCONJG( S( IC ) )*XI
IX = IX + INCX
IY = IY + INCY
IC = IC + INCC
10 CONTINUE
RETURN
*
* End of ZLARTV
*
END
*> \brief \b ZROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZROT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
*
* .. Scalar Arguments ..
* INTEGER INCX, INCY, N
* DOUBLE PRECISION C
* COMPLEX*16 S
* ..
* .. Array Arguments ..
* COMPLEX*16 CX( * ), CY( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZROT applies a plane rotation, where the cos (C) is real and the
*> sin (S) is complex, and the vectors CX and CY are complex.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of elements in the vectors CX and CY.
*> \endverbatim
*>
*> \param[in,out] CX
*> \verbatim
*> CX is COMPLEX*16 array, dimension (N)
*> On input, the vector X.
*> On output, CX is overwritten with C*X + S*Y.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between successive values of CY. INCX <> 0.
*> \endverbatim
*>
*> \param[in,out] CY
*> \verbatim
*> CY is COMPLEX*16 array, dimension (N)
*> On input, the vector Y.
*> On output, CY is overwritten with -CONJG(S)*X + C*Y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> The increment between successive values of CY. INCX <> 0.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is COMPLEX*16
*> C and S define a rotation
*> [ C S ]
*> [ -conjg(S) C ]
*> where C*C + S*CONJG(S) = 1.0.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER INCX, INCY, N
DOUBLE PRECISION C
COMPLEX*16 S
* ..
* .. Array Arguments ..
COMPLEX*16 CX( * ), CY( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IX, IY
COMPLEX*16 STEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
IF( N.LE.0 )
$ RETURN
IF( INCX.EQ.1 .AND. INCY.EQ.1 )
$ GO TO 20
*
* Code for unequal increments or equal increments not equal to 1
*
IX = 1
IY = 1
IF( INCX.LT.0 )
$ IX = ( -N+1 )*INCX + 1
IF( INCY.LT.0 )
$ IY = ( -N+1 )*INCY + 1
DO 10 I = 1, N
STEMP = C*CX( IX ) + S*CY( IY )
CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX )
CX( IX ) = STEMP
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* Code for both increments equal to 1
*
20 CONTINUE
DO 30 I = 1, N
STEMP = C*CX( I ) + S*CY( I )
CY( I ) = C*CY( I ) - DCONJG( S )*CX( I )
CX( I ) = STEMP
30 CONTINUE
RETURN
END