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