SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, $ WORK, IWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ, UPLO INTEGER INFO, LDU, LDVT, N * .. * .. Array Arguments .. INTEGER IQ( * ), IWORK( * ) DOUBLE PRECISION D( * ), E( * ), Q( * ), U( LDU, * ), $ VT( LDVT, * ), WORK( * ) * .. * * Purpose * ======= * * DBDSDC computes the singular value decomposition (SVD) of a real * N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, * using a divide and conquer method, where S is a diagonal matrix * with non-negative diagonal elements (the singular values of B), and * U and VT are orthogonal matrices of left and right singular vectors, * respectively. DBDSDC can be used to compute all singular values, * and optionally, singular vectors or singular vectors in compact 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 DLASD3 for details. * * The code currently calls DLASDQ if singular values only are desired. * However, it can be slightly modified to compute singular values * using the divide and conquer method. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': B is upper bidiagonal. * = 'L': B is lower bidiagonal. * * COMPQ (input) CHARACTER*1 * Specifies whether singular vectors are to be computed * as follows: * = 'N': Compute singular values only; * = 'P': Compute singular values and compute singular * vectors in compact form; * = 'I': Compute singular values and singular vectors. * * N (input) INTEGER * The order of the matrix B. N >= 0. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the n diagonal elements of the bidiagonal matrix B. * On exit, if INFO=0, the singular values of B. * * E (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, the elements of E contain the offdiagonal * elements of the bidiagonal matrix whose SVD is desired. * On exit, E has been destroyed. * * U (output) DOUBLE PRECISION array, dimension (LDU,N) * If COMPQ = 'I', then: * On exit, if INFO = 0, U contains the left singular vectors * of the bidiagonal matrix. * For other values of COMPQ, U is not referenced. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= 1. * If singular vectors are desired, then LDU >= max( 1, N ). * * VT (output) DOUBLE PRECISION array, dimension (LDVT,N) * If COMPQ = 'I', then: * On exit, if INFO = 0, VT' contains the right singular * vectors of the bidiagonal matrix. * For other values of COMPQ, VT is not referenced. * * LDVT (input) INTEGER * The leading dimension of the array VT. LDVT >= 1. * If singular vectors are desired, then LDVT >= max( 1, N ). * * Q (output) DOUBLE PRECISION array, dimension (LDQ) * If COMPQ = 'P', then: * On exit, if INFO = 0, Q and IQ contain the left * and right singular vectors in a compact form, * requiring O(N log N) space instead of 2*N**2. * In particular, Q contains all the DOUBLE PRECISION data in * LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) * words of memory, where SMLSIZ is returned by ILAENV and * is equal to the maximum size of the subproblems at the * bottom of the computation tree (usually about 25). * For other values of COMPQ, Q is not referenced. * * IQ (output) INTEGER array, dimension (LDIQ) * If COMPQ = 'P', then: * On exit, if INFO = 0, Q and IQ contain the left * and right singular vectors in a compact form, * requiring O(N log N) space instead of 2*N**2. * In particular, IQ contains all INTEGER data in * LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) * words of memory, where SMLSIZ is returned by ILAENV and * is equal to the maximum size of the subproblems at the * bottom of the computation tree (usually about 25). * For other values of COMPQ, IQ is not referenced. * * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * If COMPQ = 'N' then LWORK >= (4 * N). * If COMPQ = 'P' then LWORK >= (6 * N). * If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N). * * IWORK (workspace) INTEGER array, dimension (8*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 singular value. * The update process of divide and conquer failed. * * Further Details * =============== * * Based on contributions by * Ming Gu and Huan Ren, Computer Science Division, University of * California at Berkeley, USA * * ===================================================================== * Changed dimension statement in comment describing E from (N) to * (N-1). Sven, 17 Feb 05. * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. INTEGER DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC, $ ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK, $ MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ, $ SMLSZP, SQRE, START, WSTART, Z DOUBLE PRECISION CS, EPS, ORGNRM, P, R, SN * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANST EXTERNAL LSAME, ILAENV, DLAMCH, DLANST * .. * .. External Subroutines .. EXTERNAL DCOPY, DLARTG, DLASCL, DLASD0, DLASDA, DLASDQ, $ DLASET, DLASR, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG, SIGN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IUPLO = 0 IF( LSAME( UPLO, 'U' ) ) $ IUPLO = 1 IF( LSAME( UPLO, 'L' ) ) $ IUPLO = 2 IF( LSAME( COMPQ, 'N' ) ) THEN ICOMPQ = 0 ELSE IF( LSAME( COMPQ, 'P' ) ) THEN ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ICOMPQ = 2 ELSE ICOMPQ = -1 END IF IF( IUPLO.EQ.0 ) THEN INFO = -1 ELSE IF( ICOMPQ.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT. $ N ) ) ) THEN INFO = -7 ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT. $ N ) ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DBDSDC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN SMLSIZ = ILAENV( 9, 'DBDSDC', ' ', 0, 0, 0, 0 ) IF( N.EQ.1 ) THEN IF( ICOMPQ.EQ.1 ) THEN Q( 1 ) = SIGN( ONE, D( 1 ) ) Q( 1+SMLSIZ*N ) = ONE ELSE IF( ICOMPQ.EQ.2 ) THEN U( 1, 1 ) = SIGN( ONE, D( 1 ) ) VT( 1, 1 ) = ONE END IF D( 1 ) = ABS( D( 1 ) ) RETURN END IF NM1 = N - 1 * * If matrix lower bidiagonal, rotate to be upper bidiagonal * by applying Givens rotations on the left * WSTART = 1 QSTART = 3 IF( ICOMPQ.EQ.1 ) THEN CALL DCOPY( N, D, 1, Q( 1 ), 1 ) CALL DCOPY( N-1, E, 1, Q( N+1 ), 1 ) END IF IF( IUPLO.EQ.2 ) THEN QSTART = 5 WSTART = 2*N - 1 DO 10 I = 1, N - 1 CALL DLARTG( D( I ), E( I ), CS, SN, R ) D( I ) = R E( I ) = SN*D( I+1 ) D( I+1 ) = CS*D( I+1 ) IF( ICOMPQ.EQ.1 ) THEN Q( I+2*N ) = CS Q( I+3*N ) = SN ELSE IF( ICOMPQ.EQ.2 ) THEN WORK( I ) = CS WORK( NM1+I ) = -SN END IF 10 CONTINUE END IF * * If ICOMPQ = 0, use DLASDQ to compute the singular values. * IF( ICOMPQ.EQ.0 ) THEN CALL DLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U, $ LDU, WORK( WSTART ), INFO ) GO TO 40 END IF * * If N is smaller than the minimum divide size SMLSIZ, then solve * the problem with another solver. * IF( N.LE.SMLSIZ ) THEN IF( ICOMPQ.EQ.2 ) THEN CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU ) CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT ) CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U, $ LDU, WORK( WSTART ), INFO ) ELSE IF( ICOMPQ.EQ.1 ) THEN IU = 1 IVT = IU + N CALL DLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ), $ N ) CALL DLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ), $ N ) CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, $ Q( IVT+( QSTART-1 )*N ), N, $ Q( IU+( QSTART-1 )*N ), N, $ Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ), $ INFO ) END IF GO TO 40 END IF * IF( ICOMPQ.EQ.2 ) THEN CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU ) CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT ) END IF * * Scale. * ORGNRM = DLANST( 'M', N, D, E ) IF( ORGNRM.EQ.ZERO ) $ RETURN CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR ) CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR ) * EPS = DLAMCH( 'Epsilon' ) * MLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1 SMLSZP = SMLSIZ + 1 * IF( ICOMPQ.EQ.1 ) THEN IU = 1 IVT = 1 + SMLSIZ DIFL = IVT + SMLSZP DIFR = DIFL + MLVL Z = DIFR + MLVL*2 IC = Z + MLVL IS = IC + 1 POLES = IS + 1 GIVNUM = POLES + 2*MLVL * K = 1 GIVPTR = 2 PERM = 3 GIVCOL = PERM + MLVL END IF * DO 20 I = 1, N IF( ABS( D( I ) ).LT.EPS ) THEN D( I ) = SIGN( EPS, D( I ) ) END IF 20 CONTINUE * START = 1 SQRE = 0 * DO 30 I = 1, NM1 IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN * * Subproblem found. First determine its size and then * apply divide and conquer on it. * IF( I.LT.NM1 ) THEN * * A subproblem with E(I) small for I < NM1. * NSIZE = I - START + 1 ELSE IF( ABS( E( I ) ).GE.EPS ) THEN * * A subproblem with E(NM1) not too small but I = NM1. * NSIZE = N - START + 1 ELSE * * A subproblem with E(NM1) small. This implies an * 1-by-1 subproblem at D(N). Solve this 1-by-1 problem * first. * NSIZE = I - START + 1 IF( ICOMPQ.EQ.2 ) THEN U( N, N ) = SIGN( ONE, D( N ) ) VT( N, N ) = ONE ELSE IF( ICOMPQ.EQ.1 ) THEN Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) ) Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE END IF D( N ) = ABS( D( N ) ) END IF IF( ICOMPQ.EQ.2 ) THEN CALL DLASD0( NSIZE, SQRE, D( START ), E( START ), $ U( START, START ), LDU, VT( START, START ), $ LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO ) ELSE CALL DLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ), $ E( START ), Q( START+( IU+QSTART-2 )*N ), N, $ Q( START+( IVT+QSTART-2 )*N ), $ IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )* $ N ), Q( START+( DIFR+QSTART-2 )*N ), $ Q( START+( Z+QSTART-2 )*N ), $ Q( START+( POLES+QSTART-2 )*N ), $ IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ), $ N, IQ( START+PERM*N ), $ Q( START+( GIVNUM+QSTART-2 )*N ), $ Q( START+( IC+QSTART-2 )*N ), $ Q( START+( IS+QSTART-2 )*N ), $ WORK( WSTART ), IWORK, INFO ) IF( INFO.NE.0 ) THEN RETURN END IF END IF START = I + 1 END IF 30 CONTINUE * * Unscale * CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR ) 40 CONTINUE * * Use Selection Sort to minimize swaps of singular vectors * DO 60 II = 2, N I = II - 1 KK = I P = D( I ) DO 50 J = II, N IF( D( J ).GT.P ) THEN KK = J P = D( J ) END IF 50 CONTINUE IF( KK.NE.I ) THEN D( KK ) = D( I ) D( I ) = P IF( ICOMPQ.EQ.1 ) THEN IQ( I ) = KK ELSE IF( ICOMPQ.EQ.2 ) THEN CALL DSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 ) CALL DSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT ) END IF ELSE IF( ICOMPQ.EQ.1 ) THEN IQ( I ) = I END IF 60 CONTINUE * * If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO * IF( ICOMPQ.EQ.1 ) THEN IF( IUPLO.EQ.1 ) THEN IQ( N ) = 1 ELSE IQ( N ) = 0 END IF END IF * * If B is lower bidiagonal, update U by those Givens rotations * which rotated B to be upper bidiagonal * IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) ) $ CALL DLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU ) * RETURN * * End of DBDSDC * END SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), $ VT( LDVT, * ), WORK( * ) * .. * * Purpose * ======= * * DBDSQR computes the singular values and, optionally, the right and/or * left singular vectors from the singular value decomposition (SVD) of * a real N-by-N (upper or lower) bidiagonal matrix B using the implicit * zero-shift QR algorithm. The SVD of B has the form * * B = Q * S * P**T * * where S is the diagonal matrix of singular values, Q is an orthogonal * matrix of left singular vectors, and P is an orthogonal matrix of * right singular vectors. If left singular vectors are requested, this * subroutine actually returns U*Q instead of Q, and, if right singular * vectors are requested, this subroutine returns P**T*VT instead of * P**T, for given real input matrices U and VT. When U and VT are the * orthogonal matrices that reduce a general matrix A to bidiagonal * form: A = U*B*VT, as computed by DGEBRD, then * * A = (U*Q) * S * (P**T*VT) * * is the SVD of A. Optionally, the subroutine may also compute Q**T*C * for a given real input matrix C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, * LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, * no. 5, pp. 873-912, Sept 1990) and * "Accurate singular values and differential qd algorithms," by * B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics * Department, University of California at Berkeley, July 1992 * for a detailed description of the algorithm. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': B is upper bidiagonal; * = 'L': B is lower bidiagonal. * * N (input) INTEGER * The order of the matrix B. N >= 0. * * NCVT (input) INTEGER * The number of columns of the matrix VT. NCVT >= 0. * * NRU (input) INTEGER * The number of rows of the matrix U. NRU >= 0. * * NCC (input) INTEGER * The number of columns of the matrix C. NCC >= 0. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the n diagonal elements of the bidiagonal matrix B. * On exit, if INFO=0, the singular values of B in decreasing * order. * * E (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, the N-1 offdiagonal elements of the bidiagonal * matrix B. * On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E * will contain the diagonal and superdiagonal elements of a * bidiagonal matrix orthogonally equivalent to the one given * as input. * * VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. * On exit, VT is overwritten by P**T * VT. * Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. * LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. * * U (input/output) DOUBLE PRECISION array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. * Not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. * On exit, C is overwritten by Q**T * C. * Not referenced if NCC = 0. * * LDC (input) INTEGER * The leading dimension of the array C. * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. * * WORK (workspace) DOUBLE PRECISION array, dimension (2*N) * if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise * * INFO (output) INTEGER * = 0: successful exit * < 0: If INFO = -i, the i-th argument had an illegal value * > 0: the algorithm did not converge; D and E contain the * elements of a bidiagonal matrix which is orthogonally * similar to the input matrix B; if INFO = i, i * elements of E have not converged to zero. * * Internal Parameters * =================== * * TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) * TOLMUL controls the convergence criterion of the QR loop. * If it is positive, TOLMUL*EPS is the desired relative * precision in the computed singular values. * If it is negative, abs(TOLMUL*EPS*sigma_max) is the * desired absolute accuracy in the computed singular * values (corresponds to relative accuracy * abs(TOLMUL*EPS) in the largest singular value. * abs(TOLMUL) should be between 1 and 1/EPS, and preferably * between 10 (for fast convergence) and .1/EPS * (for there to be some accuracy in the results). * Default is to lose at either one eighth or 2 of the * available decimal digits in each computed singular value * (whichever is smaller). * * MAXITR INTEGER, default = 6 * MAXITR controls the maximum number of passes of the * algorithm through its inner loop. The algorithms stops * (and so fails to converge) if the number of passes * through the inner loop exceeds MAXITR*N**2. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION NEGONE PARAMETER ( NEGONE = -1.0D0 ) DOUBLE PRECISION HNDRTH PARAMETER ( HNDRTH = 0.01D0 ) DOUBLE PRECISION TEN PARAMETER ( TEN = 10.0D0 ) DOUBLE PRECISION HNDRD PARAMETER ( HNDRD = 100.0D0 ) DOUBLE PRECISION MEIGTH PARAMETER ( MEIGTH = -0.125D0 ) INTEGER MAXITR PARAMETER ( MAXITR = 6 ) * .. * .. Local Scalars .. LOGICAL LOWER, ROTATE INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, $ NM12, NM13, OLDLL, OLDM DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, $ SN, THRESH, TOL, TOLMUL, UNFL * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT, $ DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 LOWER = LSAME( UPLO, 'L' ) IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NCVT.LT.0 ) THEN INFO = -3 ELSE IF( NRU.LT.0 ) THEN INFO = -4 ELSE IF( NCC.LT.0 ) THEN INFO = -5 ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN INFO = -9 ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN INFO = -11 ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DBDSQR', -INFO ) RETURN END IF IF( N.EQ.0 ) $ RETURN IF( N.EQ.1 ) $ GO TO 160 * * ROTATE is true if any singular vectors desired, false otherwise * ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) * * If no singular vectors desired, use qd algorithm * IF( .NOT.ROTATE ) THEN CALL DLASQ1( N, D, E, WORK, INFO ) RETURN END IF * NM1 = N - 1 NM12 = NM1 + NM1 NM13 = NM12 + NM1 IDIR = 0 * * Get machine constants * EPS = DLAMCH( 'Epsilon' ) UNFL = DLAMCH( 'Safe minimum' ) * * If matrix lower bidiagonal, rotate to be upper bidiagonal * by applying Givens rotations on the left * IF( LOWER ) THEN DO 10 I = 1, N - 1 CALL DLARTG( D( I ), E( I ), CS, SN, R ) D( I ) = R E( I ) = SN*D( I+1 ) D( I+1 ) = CS*D( I+1 ) WORK( I ) = CS WORK( NM1+I ) = SN 10 CONTINUE * * Update singular vectors if desired * IF( NRU.GT.0 ) $ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U, $ LDU ) IF( NCC.GT.0 ) $ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C, $ LDC ) END IF * * Compute singular values to relative accuracy TOL * (By setting TOL to be negative, algorithm will compute * singular values to absolute accuracy ABS(TOL)*norm(input matrix)) * TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) ) TOL = TOLMUL*EPS * * Compute approximate maximum, minimum singular values * SMAX = ZERO DO 20 I = 1, N SMAX = MAX( SMAX, ABS( D( I ) ) ) 20 CONTINUE DO 30 I = 1, N - 1 SMAX = MAX( SMAX, ABS( E( I ) ) ) 30 CONTINUE SMINL = ZERO IF( TOL.GE.ZERO ) THEN * * Relative accuracy desired * SMINOA = ABS( D( 1 ) ) IF( SMINOA.EQ.ZERO ) $ GO TO 50 MU = SMINOA DO 40 I = 2, N MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) SMINOA = MIN( SMINOA, MU ) IF( SMINOA.EQ.ZERO ) $ GO TO 50 40 CONTINUE 50 CONTINUE SMINOA = SMINOA / SQRT( DBLE( N ) ) THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) ELSE * * Absolute accuracy desired * THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL ) END IF * * Prepare for main iteration loop for the singular values * (MAXIT is the maximum number of passes through the inner * loop permitted before nonconvergence signalled.) * MAXIT = MAXITR*N*N ITER = 0 OLDLL = -1 OLDM = -1 * * M points to last element of unconverged part of matrix * M = N * * Begin main iteration loop * 60 CONTINUE * * Check for convergence or exceeding iteration count * IF( M.LE.1 ) $ GO TO 160 IF( ITER.GT.MAXIT ) $ GO TO 200 * * Find diagonal block of matrix to work on * IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) $ D( M ) = ZERO SMAX = ABS( D( M ) ) SMIN = SMAX DO 70 LLL = 1, M - 1 LL = M - LLL ABSS = ABS( D( LL ) ) ABSE = ABS( E( LL ) ) IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) $ D( LL ) = ZERO IF( ABSE.LE.THRESH ) $ GO TO 80 SMIN = MIN( SMIN, ABSS ) SMAX = MAX( SMAX, ABSS, ABSE ) 70 CONTINUE LL = 0 GO TO 90 80 CONTINUE E( LL ) = ZERO * * Matrix splits since E(LL) = 0 * IF( LL.EQ.M-1 ) THEN * * Convergence of bottom singular value, return to top of loop * M = M - 1 GO TO 60 END IF 90 CONTINUE LL = LL + 1 * * E(LL) through E(M-1) are nonzero, E(LL-1) is zero * IF( LL.EQ.M-1 ) THEN * * 2 by 2 block, handle separately * CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, $ COSR, SINL, COSL ) D( M-1 ) = SIGMX E( M-1 ) = ZERO D( M ) = SIGMN * * Compute singular vectors, if desired * IF( NCVT.GT.0 ) $ CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR, $ SINR ) IF( NRU.GT.0 ) $ CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL ) IF( NCC.GT.0 ) $ CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, $ SINL ) M = M - 2 GO TO 60 END IF * * If working on new submatrix, choose shift direction * (from larger end diagonal element towards smaller) * IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN * * Chase bulge from top (big end) to bottom (small end) * IDIR = 1 ELSE * * Chase bulge from bottom (big end) to top (small end) * IDIR = 2 END IF END IF * * Apply convergence tests * IF( IDIR.EQ.1 ) THEN * * Run convergence test in forward direction * First apply standard test to bottom of matrix * IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN E( M-1 ) = ZERO GO TO 60 END IF * IF( TOL.GE.ZERO ) THEN * * If relative accuracy desired, * apply convergence criterion forward * MU = ABS( D( LL ) ) SMINL = MU DO 100 LLL = LL, M - 1 IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN E( LLL ) = ZERO GO TO 60 END IF MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 100 CONTINUE END IF * ELSE * * Run convergence test in backward direction * First apply standard test to top of matrix * IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN E( LL ) = ZERO GO TO 60 END IF * IF( TOL.GE.ZERO ) THEN * * If relative accuracy desired, * apply convergence criterion backward * MU = ABS( D( M ) ) SMINL = MU DO 110 LLL = M - 1, LL, -1 IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN E( LLL ) = ZERO GO TO 60 END IF MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 110 CONTINUE END IF END IF OLDLL = LL OLDM = M * * Compute shift. First, test if shifting would ruin relative * accuracy, and if so set the shift to zero. * IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. $ MAX( EPS, HNDRTH*TOL ) ) THEN * * Use a zero shift to avoid loss of relative accuracy * SHIFT = ZERO ELSE * * Compute the shift from 2-by-2 block at end of matrix * IF( IDIR.EQ.1 ) THEN SLL = ABS( D( LL ) ) CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R ) ELSE SLL = ABS( D( M ) ) CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R ) END IF * * Test if shift negligible, and if so set to zero * IF( SLL.GT.ZERO ) THEN IF( ( SHIFT / SLL )**2.LT.EPS ) $ SHIFT = ZERO END IF END IF * * Increment iteration count * ITER = ITER + M - LL * * If SHIFT = 0, do simplified QR iteration * IF( SHIFT.EQ.ZERO ) THEN IF( IDIR.EQ.1 ) THEN * * Chase bulge from top to bottom * Save cosines and sines for later singular vector updates * CS = ONE OLDCS = ONE DO 120 I = LL, M - 1 CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) IF( I.GT.LL ) $ E( I-1 ) = OLDSN*R CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) WORK( I-LL+1 ) = CS WORK( I-LL+1+NM1 ) = SN WORK( I-LL+1+NM12 ) = OLDCS WORK( I-LL+1+NM13 ) = OLDSN 120 CONTINUE H = D( M )*CS D( M ) = H*OLDCS E( M-1 ) = H*OLDSN * * Update singular vectors * IF( NCVT.GT.0 ) $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), $ WORK( N ), VT( LL, 1 ), LDVT ) IF( NRU.GT.0 ) $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), $ WORK( NM13+1 ), U( 1, LL ), LDU ) IF( NCC.GT.0 ) $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), $ WORK( NM13+1 ), C( LL, 1 ), LDC ) * * Test convergence * IF( ABS( E( M-1 ) ).LE.THRESH ) $ E( M-1 ) = ZERO * ELSE * * Chase bulge from bottom to top * Save cosines and sines for later singular vector updates * CS = ONE OLDCS = ONE DO 130 I = M, LL + 1, -1 CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) IF( I.LT.M ) $ E( I ) = OLDSN*R CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) WORK( I-LL ) = CS WORK( I-LL+NM1 ) = -SN WORK( I-LL+NM12 ) = OLDCS WORK( I-LL+NM13 ) = -OLDSN 130 CONTINUE H = D( LL )*CS D( LL ) = H*OLDCS E( LL ) = H*OLDSN * * Update singular vectors * IF( NCVT.GT.0 ) $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) IF( NRU.GT.0 ) $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), $ WORK( N ), U( 1, LL ), LDU ) IF( NCC.GT.0 ) $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), $ WORK( N ), C( LL, 1 ), LDC ) * * Test convergence * IF( ABS( E( LL ) ).LE.THRESH ) $ E( LL ) = ZERO END IF ELSE * * Use nonzero shift * IF( IDIR.EQ.1 ) THEN * * Chase bulge from top to bottom * Save cosines and sines for later singular vector updates * F = ( ABS( D( LL ) )-SHIFT )* $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) G = E( LL ) DO 140 I = LL, M - 1 CALL DLARTG( F, G, COSR, SINR, R ) IF( I.GT.LL ) $ E( I-1 ) = R F = COSR*D( I ) + SINR*E( I ) E( I ) = COSR*E( I ) - SINR*D( I ) G = SINR*D( I+1 ) D( I+1 ) = COSR*D( I+1 ) CALL DLARTG( F, G, COSL, SINL, R ) D( I ) = R F = COSL*E( I ) + SINL*D( I+1 ) D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) IF( I.LT.M-1 ) THEN G = SINL*E( I+1 ) E( I+1 ) = COSL*E( I+1 ) END IF WORK( I-LL+1 ) = COSR WORK( I-LL+1+NM1 ) = SINR WORK( I-LL+1+NM12 ) = COSL WORK( I-LL+1+NM13 ) = SINL 140 CONTINUE E( M-1 ) = F * * Update singular vectors * IF( NCVT.GT.0 ) $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), $ WORK( N ), VT( LL, 1 ), LDVT ) IF( NRU.GT.0 ) $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), $ WORK( NM13+1 ), U( 1, LL ), LDU ) IF( NCC.GT.0 ) $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), $ WORK( NM13+1 ), C( LL, 1 ), LDC ) * * Test convergence * IF( ABS( E( M-1 ) ).LE.THRESH ) $ E( M-1 ) = ZERO * ELSE * * Chase bulge from bottom to top * Save cosines and sines for later singular vector updates * F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / $ D( M ) ) G = E( M-1 ) DO 150 I = M, LL + 1, -1 CALL DLARTG( F, G, COSR, SINR, R ) IF( I.LT.M ) $ E( I ) = R F = COSR*D( I ) + SINR*E( I-1 ) E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) G = SINR*D( I-1 ) D( I-1 ) = COSR*D( I-1 ) CALL DLARTG( F, G, COSL, SINL, R ) D( I ) = R F = COSL*E( I-1 ) + SINL*D( I-1 ) D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) IF( I.GT.LL+1 ) THEN G = SINL*E( I-2 ) E( I-2 ) = COSL*E( I-2 ) END IF WORK( I-LL ) = COSR WORK( I-LL+NM1 ) = -SINR WORK( I-LL+NM12 ) = COSL WORK( I-LL+NM13 ) = -SINL 150 CONTINUE E( LL ) = F * * Test convergence * IF( ABS( E( LL ) ).LE.THRESH ) $ E( LL ) = ZERO * * Update singular vectors if desired * IF( NCVT.GT.0 ) $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) IF( NRU.GT.0 ) $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), $ WORK( N ), U( 1, LL ), LDU ) IF( NCC.GT.0 ) $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), $ WORK( N ), C( LL, 1 ), LDC ) END IF END IF * * QR iteration finished, go back and check convergence * GO TO 60 * * All singular values converged, so make them positive * 160 CONTINUE DO 170 I = 1, N IF( D( I ).LT.ZERO ) THEN D( I ) = -D( I ) * * Change sign of singular vectors, if desired * IF( NCVT.GT.0 ) $ CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) END IF 170 CONTINUE * * Sort the singular values into decreasing order (insertion sort on * singular values, but only one transposition per singular vector) * DO 190 I = 1, N - 1 * * Scan for smallest D(I) * ISUB = 1 SMIN = D( 1 ) DO 180 J = 2, N + 1 - I IF( D( J ).LE.SMIN ) THEN ISUB = J SMIN = D( J ) END IF 180 CONTINUE IF( ISUB.NE.N+1-I ) THEN * * Swap singular values and vectors * D( ISUB ) = D( N+1-I ) D( N+1-I ) = SMIN IF( NCVT.GT.0 ) $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), $ LDVT ) IF( NRU.GT.0 ) $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 ) IF( NCC.GT.0 ) $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) END IF 190 CONTINUE GO TO 220 * * Maximum number of iterations exceeded, failure to converge * 200 CONTINUE INFO = 0 DO 210 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 210 CONTINUE 220 CONTINUE RETURN * * End of DBDSQR * END SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER JOB INTEGER INFO, M, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), SEP( * ) * .. * * Purpose * ======= * * DDISNA computes the reciprocal condition numbers for the eigenvectors * of a real symmetric or complex Hermitian matrix or for the left or * right singular vectors of a general m-by-n matrix. The reciprocal * condition number is the 'gap' between the corresponding eigenvalue or * singular value and the nearest other one. * * The bound on the error, measured by angle in radians, in the I-th * computed vector is given by * * DLAMCH( 'E' ) * ( ANORM / SEP( I ) ) * * where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed * to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of * the error bound. * * DDISNA may also be used to compute error bounds for eigenvectors of * the generalized symmetric definite eigenproblem. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies for which problem the reciprocal condition numbers * should be computed: * = 'E': the eigenvectors of a symmetric/Hermitian matrix; * = 'L': the left singular vectors of a general matrix; * = 'R': the right singular vectors of a general matrix. * * M (input) INTEGER * The number of rows of the matrix. M >= 0. * * N (input) INTEGER * If JOB = 'L' or 'R', the number of columns of the matrix, * in which case N >= 0. Ignored if JOB = 'E'. * * D (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E' * dimension (min(M,N)) if JOB = 'L' or 'R' * The eigenvalues (if JOB = 'E') or singular values (if JOB = * 'L' or 'R') of the matrix, in either increasing or decreasing * order. If singular values, they must be non-negative. * * SEP (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E' * dimension (min(M,N)) if JOB = 'L' or 'R' * The reciprocal condition numbers of the vectors. * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL DECR, EIGEN, INCR, LEFT, RIGHT, SING INTEGER I, K DOUBLE PRECISION ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 EIGEN = LSAME( JOB, 'E' ) LEFT = LSAME( JOB, 'L' ) RIGHT = LSAME( JOB, 'R' ) SING = LEFT .OR. RIGHT IF( EIGEN ) THEN K = M ELSE IF( SING ) THEN K = MIN( M, N ) END IF IF( .NOT.EIGEN .AND. .NOT.SING ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( K.LT.0 ) THEN INFO = -3 ELSE INCR = .TRUE. DECR = .TRUE. DO 10 I = 1, K - 1 IF( INCR ) $ INCR = INCR .AND. D( I ).LE.D( I+1 ) IF( DECR ) $ DECR = DECR .AND. D( I ).GE.D( I+1 ) 10 CONTINUE IF( SING .AND. K.GT.0 ) THEN IF( INCR ) $ INCR = INCR .AND. ZERO.LE.D( 1 ) IF( DECR ) $ DECR = DECR .AND. D( K ).GE.ZERO END IF IF( .NOT.( INCR .OR. DECR ) ) $ INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DDISNA', -INFO ) RETURN END IF * * Quick return if possible * IF( K.EQ.0 ) $ RETURN * * Compute reciprocal condition numbers * IF( K.EQ.1 ) THEN SEP( 1 ) = DLAMCH( 'O' ) ELSE OLDGAP = ABS( D( 2 )-D( 1 ) ) SEP( 1 ) = OLDGAP DO 20 I = 2, K - 1 NEWGAP = ABS( D( I+1 )-D( I ) ) SEP( I ) = MIN( OLDGAP, NEWGAP ) OLDGAP = NEWGAP 20 CONTINUE SEP( K ) = OLDGAP END IF IF( SING ) THEN IF( ( LEFT .AND. M.GT.N ) .OR. ( RIGHT .AND. M.LT.N ) ) THEN IF( INCR ) $ SEP( 1 ) = MIN( SEP( 1 ), D( 1 ) ) IF( DECR ) $ SEP( K ) = MIN( SEP( K ), D( K ) ) END IF END IF * * Ensure that reciprocal condition numbers are not less than * threshold, in order to limit the size of the error bound * EPS = DLAMCH( 'E' ) SAFMIN = DLAMCH( 'S' ) ANORM = MAX( ABS( D( 1 ) ), ABS( D( K ) ) ) IF( ANORM.EQ.ZERO ) THEN THRESH = EPS ELSE THRESH = MAX( EPS*ANORM, SAFMIN ) END IF DO 30 I = 1, K SEP( I ) = MAX( SEP( I ), THRESH ) 30 CONTINUE * RETURN * * End of DDISNA * END SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, $ LDQ, PT, LDPT, C, LDC, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER VECT INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), C( LDC, * ), D( * ), E( * ), $ PT( LDPT, * ), Q( LDQ, * ), WORK( * ) * .. * * Purpose * ======= * * DGBBRD reduces a real general m-by-n band matrix A to upper * bidiagonal form B by an orthogonal transformation: Q' * A * P = B. * * The routine computes B, and optionally forms Q or P', or computes * Q'*C for a given matrix C. * * Arguments * ========= * * VECT (input) CHARACTER*1 * Specifies whether or not the matrices Q and P' are to be * formed. * = 'N': do not form Q or P'; * = 'Q': form Q only; * = 'P': form P' only; * = 'B': form both. * * 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. * * NCC (input) INTEGER * The number of columns of the matrix C. NCC >= 0. * * KL (input) INTEGER * The number of subdiagonals of the matrix A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals of the matrix A. KU >= 0. * * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) * On entry, the m-by-n band matrix A, stored in rows 1 to * KL+KU+1. The j-th column of A is stored in the j-th column of * the array AB as follows: * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). * On exit, A is overwritten by values generated during the * reduction. * * LDAB (input) INTEGER * The leading dimension of the array A. LDAB >= KL+KU+1. * * D (output) DOUBLE PRECISION array, dimension (min(M,N)) * The diagonal elements of the bidiagonal matrix B. * * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) * The superdiagonal elements of the bidiagonal matrix B. * * Q (output) DOUBLE PRECISION array, dimension (LDQ,M) * If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q. * If VECT = 'N' or 'P', the array Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. * * PT (output) DOUBLE PRECISION array, dimension (LDPT,N) * If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'. * If VECT = 'N' or 'Q', the array PT is not referenced. * * LDPT (input) INTEGER * The leading dimension of the array PT. * LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,NCC) * On entry, an m-by-ncc matrix C. * On exit, C is overwritten by Q'*C. * C is not referenced if NCC = 0. * * LDC (input) INTEGER * The leading dimension of the array C. * LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0. * * WORK (workspace) DOUBLE PRECISION array, dimension (2*max(M,N)) * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL WANTB, WANTC, WANTPT, WANTQ INTEGER I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1, $ KUN, L, MINMN, ML, ML0, MN, MU, MU0, NR, NRT DOUBLE PRECISION RA, RB, RC, RS * .. * .. External Subroutines .. EXTERNAL DLARGV, DLARTG, DLARTV, DLASET, DROT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Test the input parameters * WANTB = LSAME( VECT, 'B' ) WANTQ = LSAME( VECT, 'Q' ) .OR. WANTB WANTPT = LSAME( VECT, 'P' ) .OR. WANTB WANTC = NCC.GT.0 KLU1 = KL + KU + 1 INFO = 0 IF( .NOT.WANTQ .AND. .NOT.WANTPT .AND. .NOT.LSAME( VECT, 'N' ) ) $ THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( NCC.LT.0 ) THEN INFO = -4 ELSE IF( KL.LT.0 ) THEN INFO = -5 ELSE IF( KU.LT.0 ) THEN INFO = -6 ELSE IF( LDAB.LT.KLU1 ) THEN INFO = -8 ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDPT.LT.1 .OR. WANTPT .AND. LDPT.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDC.LT.1 .OR. WANTC .AND. LDC.LT.MAX( 1, M ) ) THEN INFO = -16 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGBBRD', -INFO ) RETURN END IF * * Initialize Q and P' to the unit matrix, if needed * IF( WANTQ ) $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ ) IF( WANTPT ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, PT, LDPT ) * * Quick return if possible. * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * MINMN = MIN( M, N ) * IF( KL+KU.GT.1 ) THEN * * Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce * first to lower bidiagonal form and then transform to upper * bidiagonal * IF( KU.GT.0 ) THEN ML0 = 1 MU0 = 2 ELSE ML0 = 2 MU0 = 1 END IF * * Wherever possible, plane rotations are generated and applied in * vector operations of length NR over the index set J1:J2:KLU1. * * The sines of the plane rotations are stored in WORK(1:max(m,n)) * and the cosines in WORK(max(m,n)+1:2*max(m,n)). * MN = MAX( M, N ) KLM = MIN( M-1, KL ) KUN = MIN( N-1, KU ) KB = KLM + KUN KB1 = KB + 1 INCA = KB1*LDAB NR = 0 J1 = KLM + 2 J2 = 1 - KUN * DO 90 I = 1, MINMN * * Reduce i-th column and i-th row of matrix to bidiagonal form * ML = KLM + 1 MU = KUN + 1 DO 80 KK = 1, KB J1 = J1 + KB J2 = J2 + KB * * generate plane rotations to annihilate nonzero elements * which have been created below the band * IF( NR.GT.0 ) $ CALL DLARGV( NR, AB( KLU1, J1-KLM-1 ), INCA, $ WORK( J1 ), KB1, WORK( MN+J1 ), KB1 ) * * apply plane rotations from the left * DO 10 L = 1, KB IF( J2-KLM+L-1.GT.N ) THEN NRT = NR - 1 ELSE NRT = NR END IF IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( KLU1-L, J1-KLM+L-1 ), INCA, $ AB( KLU1-L+1, J1-KLM+L-1 ), INCA, $ WORK( MN+J1 ), WORK( J1 ), KB1 ) 10 CONTINUE * IF( ML.GT.ML0 ) THEN IF( ML.LE.M-I+1 ) THEN * * generate plane rotation to annihilate a(i+ml-1,i) * within the band, and apply rotation from the left * CALL DLARTG( AB( KU+ML-1, I ), AB( KU+ML, I ), $ WORK( MN+I+ML-1 ), WORK( I+ML-1 ), $ RA ) AB( KU+ML-1, I ) = RA IF( I.LT.N ) $ CALL DROT( MIN( KU+ML-2, N-I ), $ AB( KU+ML-2, I+1 ), LDAB-1, $ AB( KU+ML-1, I+1 ), LDAB-1, $ WORK( MN+I+ML-1 ), WORK( I+ML-1 ) ) END IF NR = NR + 1 J1 = J1 - KB1 END IF * IF( WANTQ ) THEN * * accumulate product of plane rotations in Q * DO 20 J = J1, J2, KB1 CALL DROT( M, Q( 1, J-1 ), 1, Q( 1, J ), 1, $ WORK( MN+J ), WORK( J ) ) 20 CONTINUE END IF * IF( WANTC ) THEN * * apply plane rotations to C * DO 30 J = J1, J2, KB1 CALL DROT( NCC, C( J-1, 1 ), LDC, C( J, 1 ), LDC, $ WORK( MN+J ), WORK( J ) ) 30 CONTINUE END IF * IF( J2+KUN.GT.N ) THEN * * adjust J2 to keep within the bounds of the matrix * NR = NR - 1 J2 = J2 - KB1 END IF * DO 40 J = J1, J2, KB1 * * create nonzero element a(j-1,j+ku) above the band * and store it in WORK(n+1:2*n) * WORK( J+KUN ) = WORK( J )*AB( 1, J+KUN ) AB( 1, J+KUN ) = WORK( MN+J )*AB( 1, J+KUN ) 40 CONTINUE * * generate plane rotations to annihilate nonzero elements * which have been generated above the band * IF( NR.GT.0 ) $ CALL DLARGV( NR, AB( 1, J1+KUN-1 ), INCA, $ WORK( J1+KUN ), KB1, WORK( MN+J1+KUN ), $ KB1 ) * * apply plane rotations from the right * DO 50 L = 1, KB IF( J2+L-1.GT.M ) THEN NRT = NR - 1 ELSE NRT = NR END IF IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( L+1, J1+KUN-1 ), INCA, $ AB( L, J1+KUN ), INCA, $ WORK( MN+J1+KUN ), WORK( J1+KUN ), $ KB1 ) 50 CONTINUE * IF( ML.EQ.ML0 .AND. MU.GT.MU0 ) THEN IF( MU.LE.N-I+1 ) THEN * * generate plane rotation to annihilate a(i,i+mu-1) * within the band, and apply rotation from the right * CALL DLARTG( AB( KU-MU+3, I+MU-2 ), $ AB( KU-MU+2, I+MU-1 ), $ WORK( MN+I+MU-1 ), WORK( I+MU-1 ), $ RA ) AB( KU-MU+3, I+MU-2 ) = RA CALL DROT( MIN( KL+MU-2, M-I ), $ AB( KU-MU+4, I+MU-2 ), 1, $ AB( KU-MU+3, I+MU-1 ), 1, $ WORK( MN+I+MU-1 ), WORK( I+MU-1 ) ) END IF NR = NR + 1 J1 = J1 - KB1 END IF * IF( WANTPT ) THEN * * accumulate product of plane rotations in P' * DO 60 J = J1, J2, KB1 CALL DROT( N, PT( J+KUN-1, 1 ), LDPT, $ PT( J+KUN, 1 ), LDPT, WORK( MN+J+KUN ), $ WORK( J+KUN ) ) 60 CONTINUE END IF * IF( J2+KB.GT.M ) THEN * * adjust J2 to keep within the bounds of the matrix * NR = NR - 1 J2 = J2 - KB1 END IF * DO 70 J = J1, J2, KB1 * * create nonzero element a(j+kl+ku,j+ku-1) below the * band and store it in WORK(1:n) * WORK( J+KB ) = WORK( J+KUN )*AB( KLU1, J+KUN ) AB( KLU1, J+KUN ) = WORK( MN+J+KUN )*AB( KLU1, J+KUN ) 70 CONTINUE * IF( ML.GT.ML0 ) THEN ML = ML - 1 ELSE MU = MU - 1 END IF 80 CONTINUE 90 CONTINUE END IF * IF( KU.EQ.0 .AND. KL.GT.0 ) THEN * * A has been reduced to lower bidiagonal form * * Transform lower bidiagonal form to upper bidiagonal by applying * plane rotations from the left, storing diagonal elements in D * and off-diagonal elements in E * DO 100 I = 1, MIN( M-1, N ) CALL DLARTG( AB( 1, I ), AB( 2, I ), RC, RS, RA ) D( I ) = RA IF( I.LT.N ) THEN E( I ) = RS*AB( 1, I+1 ) AB( 1, I+1 ) = RC*AB( 1, I+1 ) END IF IF( WANTQ ) $ CALL DROT( M, Q( 1, I ), 1, Q( 1, I+1 ), 1, RC, RS ) IF( WANTC ) $ CALL DROT( NCC, C( I, 1 ), LDC, C( I+1, 1 ), LDC, RC, $ RS ) 100 CONTINUE IF( M.LE.N ) $ D( M ) = AB( 1, M ) ELSE IF( KU.GT.0 ) THEN * * A has been reduced to upper bidiagonal form * IF( M.LT.N ) THEN * * Annihilate a(m,m+1) by applying plane rotations from the * right, storing diagonal elements in D and off-diagonal * elements in E * RB = AB( KU, M+1 ) DO 110 I = M, 1, -1 CALL DLARTG( AB( KU+1, I ), RB, RC, RS, RA ) D( I ) = RA IF( I.GT.1 ) THEN RB = -RS*AB( KU, I ) E( I-1 ) = RC*AB( KU, I ) END IF IF( WANTPT ) $ CALL DROT( N, PT( I, 1 ), LDPT, PT( M+1, 1 ), LDPT, $ RC, RS ) 110 CONTINUE ELSE * * Copy off-diagonal elements to E and diagonal elements to D * DO 120 I = 1, MINMN - 1 E( I ) = AB( KU, I+1 ) 120 CONTINUE DO 130 I = 1, MINMN D( I ) = AB( KU+1, I ) 130 CONTINUE END IF ELSE * * A is diagonal. Set elements of E to zero and copy diagonal * elements to D. * DO 140 I = 1, MINMN - 1 E( I ) = ZERO 140 CONTINUE DO 150 I = 1, MINMN D( I ) = AB( 1, I ) 150 CONTINUE END IF RETURN * * End of DGBBRD * END SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER NORM INTEGER INFO, KL, KU, LDAB, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * Purpose * ======= * * DGBCON estimates the reciprocal of the condition number of a real * general band matrix A, in either the 1-norm or the infinity-norm, * using the LU factorization computed by DGBTRF. * * An estimate is obtained for norm(inv(A)), and the reciprocal of the * condition number is computed as * RCOND = 1 / ( norm(A) * norm(inv(A)) ). * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies whether the 1-norm condition number or the * infinity-norm condition number is required: * = '1' or 'O': 1-norm; * = 'I': Infinity-norm. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * AB (input) DOUBLE PRECISION array, dimension (LDAB,N) * Details of the LU factorization of the band matrix A, as * computed by DGBTRF. U is stored as an upper triangular band * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and * the multipliers used during the factorization are stored in * rows KL+KU+2 to 2*KL+KU+1. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= N, row i of the matrix was * interchanged with row IPIV(i). * * ANORM (input) DOUBLE PRECISION * If NORM = '1' or 'O', the 1-norm of the original matrix A. * If NORM = 'I', the infinity-norm of the original matrix A. * * RCOND (output) DOUBLE PRECISION * The reciprocal of the condition number of the matrix A, * computed as RCOND = 1/(norm(A) * norm(inv(A))). * * WORK (workspace) DOUBLE PRECISION array, dimension (3*N) * * IWORK (workspace) INTEGER array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LNOTI, ONENRM CHARACTER NORMIN INTEGER IX, J, JP, KASE, KASE1, KD, LM DOUBLE PRECISION AINVNM, SCALE, SMLNUM, T * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DLACN2, DLATBS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN INFO = -6 ELSE IF( ANORM.LT.ZERO ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGBCON', -INFO ) RETURN END IF * * Quick return if possible * RCOND = ZERO IF( N.EQ.0 ) THEN RCOND = ONE RETURN ELSE IF( ANORM.EQ.ZERO ) THEN RETURN END IF * SMLNUM = DLAMCH( 'Safe minimum' ) * * Estimate the norm of inv(A). * AINVNM = ZERO NORMIN = 'N' IF( ONENRM ) THEN KASE1 = 1 ELSE KASE1 = 2 END IF KD = KL + KU + 1 LNOTI = KL.GT.0 KASE = 0 10 CONTINUE CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * * Multiply by inv(L). * IF( LNOTI ) THEN DO 20 J = 1, N - 1 LM = MIN( KL, N-J ) JP = IPIV( J ) T = WORK( JP ) IF( JP.NE.J ) THEN WORK( JP ) = WORK( J ) WORK( J ) = T END IF CALL DAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 ) 20 CONTINUE END IF * * Multiply by inv(U). * CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), $ INFO ) ELSE * * Multiply by inv(U'). * CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), $ INFO ) * * Multiply by inv(L'). * IF( LNOTI ) THEN DO 30 J = N - 1, 1, -1 LM = MIN( KL, N-J ) WORK( J ) = WORK( J ) - DDOT( LM, AB( KD+1, J ), 1, $ WORK( J+1 ), 1 ) JP = IPIV( J ) IF( JP.NE.J ) THEN T = WORK( JP ) WORK( JP ) = WORK( J ) WORK( J ) = T END IF 30 CONTINUE END IF END IF * * Divide X by 1/SCALE if doing so will not cause overflow. * NORMIN = 'Y' IF( SCALE.NE.ONE ) THEN IX = IDAMAX( N, WORK, 1 ) IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) $ GO TO 40 CALL DRSCL( N, SCALE, WORK, 1 ) END IF GO TO 10 END IF * * Compute the estimate of the reciprocal condition number. * IF( AINVNM.NE.ZERO ) $ RCOND = ( ONE / AINVNM ) / ANORM * 40 CONTINUE RETURN * * End of DGBCON * END SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) * .. * * Purpose * ======= * * DGBEQU computes row and column scalings intended to equilibrate an * M-by-N band matrix A and reduce its condition number. R returns the * row scale factors and C the column scale factors, chosen to try to * make the largest element in each row and column of the matrix B with * elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. * * R(i) and C(j) are restricted to be between SMLNUM = smallest safe * number and BIGNUM = largest safe number. Use of these scaling * factors is not guaranteed to reduce the condition number of A but * works well in practice. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * AB (input) DOUBLE PRECISION array, dimension (LDAB,N) * The band matrix A, stored in rows 1 to KL+KU+1. The j-th * column of A is stored in the j-th column of the array AB as * follows: * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= KL+KU+1. * * R (output) DOUBLE PRECISION array, dimension (M) * If INFO = 0, or INFO > M, R contains the row scale factors * for A. * * C (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, C contains the column scale factors for A. * * ROWCND (output) DOUBLE PRECISION * If INFO = 0 or INFO > M, ROWCND contains the ratio of the * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and * AMAX is neither too large nor too small, it is not worth * scaling by R. * * COLCND (output) DOUBLE PRECISION * If INFO = 0, COLCND contains the ratio of the smallest * C(i) to the largest C(i). If COLCND >= 0.1, it is not * worth scaling by C. * * AMAX (output) DOUBLE PRECISION * Absolute value of largest matrix element. If AMAX is very * close to overflow or very close to underflow, the matrix * should be scaled. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, and i is * <= M: the i-th row of A is exactly zero * > M: the (i-M)-th column of A is exactly zero * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, KD DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, 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( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KL+KU+1 ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGBEQU', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN ROWCND = ONE COLCND = ONE AMAX = ZERO RETURN END IF * * Get machine constants. * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * * Compute row scale factors. * DO 10 I = 1, M R( I ) = ZERO 10 CONTINUE * * Find the maximum element in each row. * KD = KU + 1 DO 30 J = 1, N DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M ) R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) ) 20 CONTINUE 30 CONTINUE * * Find the maximum and minimum scale factors. * RCMIN = BIGNUM RCMAX = ZERO DO 40 I = 1, M RCMAX = MAX( RCMAX, R( I ) ) RCMIN = MIN( RCMIN, R( I ) ) 40 CONTINUE AMAX = RCMAX * IF( RCMIN.EQ.ZERO ) THEN * * Find the first zero scale factor and return an error code. * DO 50 I = 1, M IF( R( I ).EQ.ZERO ) THEN INFO = I RETURN END IF 50 CONTINUE ELSE * * Invert the scale factors. * DO 60 I = 1, M R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) 60 CONTINUE * * Compute ROWCND = min(R(I)) / max(R(I)) * ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) END IF * * Compute column scale factors * DO 70 J = 1, N C( J ) = ZERO 70 CONTINUE * * Find the maximum element in each column, * assuming the row scaling computed above. * KD = KU + 1 DO 90 J = 1, N DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M ) C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) ) 80 CONTINUE 90 CONTINUE * * Find the maximum and minimum scale factors. * RCMIN = BIGNUM RCMAX = ZERO DO 100 J = 1, N RCMIN = MIN( RCMIN, C( J ) ) RCMAX = MAX( RCMAX, C( J ) ) 100 CONTINUE * IF( RCMIN.EQ.ZERO ) THEN * * Find the first zero scale factor and return an error code. * DO 110 J = 1, N IF( C( J ).EQ.ZERO ) THEN INFO = M + J RETURN END IF 110 CONTINUE ELSE * * Invert the scale factors. * DO 120 J = 1, N C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) 120 CONTINUE * * Compute COLCND = min(C(J)) / max(C(J)) * COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) END IF * RETURN * * End of DGBEQU * END SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. * * Purpose * ======= * * DGBRFS improves the computed solution to a system of linear * equations when the coefficient matrix is banded, and provides * error bounds and backward error estimates for the solution. * * Arguments * ========= * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations: * = 'N': A * X = B (No transpose) * = 'T': A**T * X = B (Transpose) * = 'C': A**H * X = B (Conjugate transpose = Transpose) * * N (input) INTEGER * The order of the matrix A. N >= 0. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrices B and X. NRHS >= 0. * * AB (input) DOUBLE PRECISION array, dimension (LDAB,N) * The original band matrix A, stored in rows 1 to KL+KU+1. * The j-th column of A is stored in the j-th column of the * array AB as follows: * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= KL+KU+1. * * AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) * Details of the LU factorization of the band matrix A, as * computed by DGBTRF. U is stored as an upper triangular band * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and * the multipliers used during the factorization are stored in * rows KL+KU+2 to 2*KL+KU+1. * * LDAFB (input) INTEGER * The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices from DGBTRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) * The right hand side matrix B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) * On entry, the solution matrix X, as computed by DGBTRS. * On exit, the improved solution matrix X. * * LDX (input) INTEGER * The leading dimension of the array X. LDX >= max(1,N). * * FERR (output) DOUBLE PRECISION array, dimension (NRHS) * The estimated forward error bound for each solution vector * X(j) (the j-th column of the solution matrix X). * If XTRUE is the true solution corresponding to X(j), FERR(j) * is an estimated upper bound for the magnitude of the largest * element in (X(j) - XTRUE) divided by the magnitude of the * largest element in X(j). The estimate is as reliable as * the estimate for RCOND, and is almost always a slight * overestimate of the true error. * * BERR (output) DOUBLE PRECISION array, dimension (NRHS) * The componentwise relative backward error of each solution * vector X(j) (i.e., the smallest relative change in * any element of A or B that makes X(j) an exact solution). * * WORK (workspace) DOUBLE PRECISION array, dimension (3*N) * * IWORK (workspace) INTEGER array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Internal Parameters * =================== * * ITMAX is the maximum number of steps of iterative refinement. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D+0 ) DOUBLE PRECISION THREE PARAMETER ( THREE = 3.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN CHARACTER TRANST INTEGER COUNT, I, J, K, KASE, KK, NZ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGBMV, DGBTRS, DLACN2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) THEN INFO = -5 ELSE IF( LDAB.LT.KL+KU+1 ) THEN INFO = -7 ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -14 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGBRFS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN DO 10 J = 1, NRHS FERR( J ) = ZERO BERR( J ) = ZERO 10 CONTINUE RETURN END IF * IF( NOTRAN ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * * NZ = maximum number of nonzero elements in each row of A, plus 1 * NZ = MIN( KL+KU+2, N+1 ) EPS = DLAMCH( 'Epsilon' ) SAFMIN = DLAMCH( 'Safe minimum' ) SAFE1 = NZ*SAFMIN SAFE2 = SAFE1 / EPS * * Do for each right hand side * DO 140 J = 1, NRHS * COUNT = 1 LSTRES = THREE 20 CONTINUE * * Loop until stopping criterion is satisfied. * * Compute residual R = B - op(A) * X, * where op(A) = A, A**T, or A**H, depending on TRANS. * CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) CALL DGBMV( TRANS, N, N, KL, KU, -ONE, AB, LDAB, X( 1, J ), 1, $ ONE, WORK( N+1 ), 1 ) * * Compute componentwise relative backward error from formula * * max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) * * where abs(Z) is the componentwise absolute value of the matrix * or vector Z. If the i-th component of the denominator is less * than SAFE2, then SAFE1 is added to the i-th components of the * numerator and denominator before dividing. * DO 30 I = 1, N WORK( I ) = ABS( B( I, J ) ) 30 CONTINUE * * Compute abs(op(A))*abs(X) + abs(B). * IF( NOTRAN ) THEN DO 50 K = 1, N KK = KU + 1 - K XK = ABS( X( K, J ) ) DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL ) WORK( I ) = WORK( I ) + ABS( AB( KK+I, K ) )*XK 40 CONTINUE 50 CONTINUE ELSE DO 70 K = 1, N S = ZERO KK = KU + 1 - K DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL ) S = S + ABS( AB( KK+I, K ) )*ABS( X( I, J ) ) 60 CONTINUE WORK( K ) = WORK( K ) + S 70 CONTINUE END IF S = ZERO DO 80 I = 1, N IF( WORK( I ).GT.SAFE2 ) THEN S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) ) ELSE S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / $ ( WORK( I )+SAFE1 ) ) END IF 80 CONTINUE BERR( J ) = S * * Test stopping criterion. Continue iterating if * 1) The residual BERR(J) is larger than machine epsilon, and * 2) BERR(J) decreased by at least a factor of 2 during the * last iteration, and * 3) At most ITMAX iterations tried. * IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. $ COUNT.LE.ITMAX ) THEN * * Update solution and try again. * CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, $ WORK( N+1 ), N, INFO ) CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 ) LSTRES = BERR( J ) COUNT = COUNT + 1 GO TO 20 END IF * * Bound error from formula * * norm(X - XTRUE) / norm(X) .le. FERR = * norm( abs(inv(op(A)))* * ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) * * where * norm(Z) is the magnitude of the largest component of Z * inv(op(A)) is the inverse of op(A) * abs(Z) is the componentwise absolute value of the matrix or * vector Z * NZ is the maximum number of nonzeros in any row of A, plus 1 * EPS is machine epsilon * * The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) * is incremented by SAFE1 if the i-th component of * abs(op(A))*abs(X) + abs(B) is less than SAFE2. * * Use DLACN2 to estimate the infinity-norm of the matrix * inv(op(A)) * diag(W), * where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) * DO 90 I = 1, N IF( WORK( I ).GT.SAFE2 ) THEN WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) ELSE WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1 END IF 90 CONTINUE * KASE = 0 100 CONTINUE CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), $ KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Multiply by diag(W)*inv(op(A)**T). * CALL DGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV, $ WORK( N+1 ), N, INFO ) DO 110 I = 1, N WORK( N+I ) = WORK( N+I )*WORK( I ) 110 CONTINUE ELSE * * Multiply by inv(op(A))*diag(W). * DO 120 I = 1, N WORK( N+I ) = WORK( N+I )*WORK( I ) 120 CONTINUE CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, $ WORK( N+1 ), N, INFO ) END IF GO TO 100 END IF * * Normalize error. * LSTRES = ZERO DO 130 I = 1, N LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) 130 CONTINUE IF( LSTRES.NE.ZERO ) $ FERR( J ) = FERR( J ) / LSTRES * 140 CONTINUE * RETURN * * End of DGBRFS * END SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AB( LDAB, * ) * .. * * Purpose * ======= * * DGBTF2 computes an LU factorization of a real m-by-n band matrix A * using partial pivoting with row interchanges. * * This is the unblocked version of the algorithm, calling Level 2 BLAS. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) * On entry, the matrix A in band storage, in rows KL+1 to * 2*KL+KU+1; rows 1 to KL of the array need not be set. * The j-th column of A is stored in the j-th column of the * array AB as follows: * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) * * On exit, details of the factorization: U is stored as an * upper triangular band matrix with KL+KU superdiagonals in * rows 1 to KL+KU+1, and the multipliers used during the * factorization are stored in rows KL+KU+2 to 2*KL+KU+1. * See below for further details. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * 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. * * Further Details * =============== * * The band storage scheme is illustrated by the following example, when * M = N = 6, KL = 2, KU = 1: * * On entry: On exit: * * * * * + + + * * * u14 u25 u36 * * * + + + + * * u13 u24 u35 u46 * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * * a31 a42 a53 a64 * * m31 m42 m53 m64 * * * * Array elements marked * are not used by the routine; elements marked * + need not be set on entry, but are required by the routine to store * elements of U, because of fill-in resulting from the row * interchanges. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, JP, JU, KM, KV * .. * .. External Functions .. INTEGER IDAMAX EXTERNAL IDAMAX * .. * .. External Subroutines .. EXTERNAL DGER, DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * KV is the number of superdiagonals in the factor U, allowing for * fill-in. * KV = KU + KL * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KL+KV+1 ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGBTF2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Gaussian elimination with partial pivoting * * Set fill-in elements in columns KU+2 to KV to zero. * DO 20 J = KU + 2, MIN( KV, N ) DO 10 I = KV - J + 2, KL AB( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * * JU is the index of the last column affected by the current stage * of the factorization. * JU = 1 * DO 40 J = 1, MIN( M, N ) * * Set fill-in elements in column J+KV to zero. * IF( J+KV.LE.N ) THEN DO 30 I = 1, KL AB( I, J+KV ) = ZERO 30 CONTINUE END IF * * Find pivot and test for singularity. KM is the number of * subdiagonal elements in the current column. * KM = MIN( KL, M-J ) JP = IDAMAX( KM+1, AB( KV+1, J ), 1 ) IPIV( J ) = JP + J - 1 IF( AB( KV+JP, J ).NE.ZERO ) THEN JU = MAX( JU, MIN( J+KU+JP-1, N ) ) * * Apply interchange to columns J to JU. * IF( JP.NE.1 ) $ CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, $ AB( KV+1, J ), LDAB-1 ) * IF( KM.GT.0 ) THEN * * Compute multipliers. * CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 ) * * Update trailing submatrix within the band. * IF( JU.GT.J ) $ CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1, $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), $ LDAB-1 ) END IF ELSE * * If pivot is zero, set INFO to the index of the pivot * unless a zero pivot has already been found. * IF( INFO.EQ.0 ) $ INFO = J END IF 40 CONTINUE RETURN * * End of DGBTF2 * END SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AB( LDAB, * ) * .. * * Purpose * ======= * * DGBTRF computes an LU factorization of a real m-by-n band matrix A * using partial pivoting with row interchanges. * * This is the blocked version of the algorithm, calling Level 3 BLAS. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) * On entry, the matrix A in band storage, in rows KL+1 to * 2*KL+KU+1; rows 1 to KL of the array need not be set. * The j-th column of A is stored in the j-th column of the * array AB as follows: * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) * * On exit, details of the factorization: U is stored as an * upper triangular band matrix with KL+KU superdiagonals in * rows 1 to KL+KU+1, and the multipliers used during the * factorization are stored in rows KL+KU+2 to 2*KL+KU+1. * See below for further details. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * 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. * * Further Details * =============== * * The band storage scheme is illustrated by the following example, when * M = N = 6, KL = 2, KU = 1: * * On entry: On exit: * * * * * + + + * * * u14 u25 u36 * * * + + + + * * u13 u24 u35 u46 * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * * a31 a42 a53 a64 * * m31 m42 m53 m64 * * * * Array elements marked * are not used by the routine; elements marked * + need not be set on entry, but are required by the routine to store * elements of U because of fill-in resulting from the row interchanges. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) INTEGER NBMAX, LDWORK PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 ) * .. * .. Local Scalars .. INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, $ JU, K2, KM, KV, NB, NW DOUBLE PRECISION TEMP * .. * .. Local Arrays .. DOUBLE PRECISION WORK13( LDWORK, NBMAX ), $ WORK31( LDWORK, NBMAX ) * .. * .. External Functions .. INTEGER IDAMAX, ILAENV EXTERNAL IDAMAX, ILAENV * .. * .. External Subroutines .. EXTERNAL DCOPY, DGBTF2, DGEMM, DGER, DLASWP, DSCAL, $ DSWAP, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * KV is the number of superdiagonals in the factor U, allowing for * fill-in * KV = KU + KL * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KL+KV+1 ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGBTRF', -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, 'DGBTRF', ' ', M, N, KL, KU ) * * The block size must not exceed the limit set by the size of the * local arrays WORK13 and WORK31. * NB = MIN( NB, NBMAX ) * IF( NB.LE.1 .OR. NB.GT.KL ) THEN * * Use unblocked code * CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) ELSE * * Use blocked code * * Zero the superdiagonal elements of the work array WORK13 * DO 20 J = 1, NB DO 10 I = 1, J - 1 WORK13( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * * Zero the subdiagonal elements of the work array WORK31 * DO 40 J = 1, NB DO 30 I = J + 1, NB WORK31( I, J ) = ZERO 30 CONTINUE 40 CONTINUE * * Gaussian elimination with partial pivoting * * Set fill-in elements in columns KU+2 to KV to zero * DO 60 J = KU + 2, MIN( KV, N ) DO 50 I = KV - J + 2, KL AB( I, J ) = ZERO 50 CONTINUE 60 CONTINUE * * JU is the index of the last column affected by the current * stage of the factorization * JU = 1 * DO 180 J = 1, MIN( M, N ), NB JB = MIN( NB, MIN( M, N )-J+1 ) * * The active part of the matrix is partitioned * * A11 A12 A13 * A21 A22 A23 * A31 A32 A33 * * Here A11, A21 and A31 denote the current block of JB columns * which is about to be factorized. The number of rows in the * partitioning are JB, I2, I3 respectively, and the numbers * of columns are JB, J2, J3. The superdiagonal elements of A13 * and the subdiagonal elements of A31 lie outside the band. * I2 = MIN( KL-JB, M-J-JB+1 ) I3 = MIN( JB, M-J-KL+1 ) * * J2 and J3 are computed after JU has been updated. * * Factorize the current block of JB columns * DO 80 JJ = J, J + JB - 1 * * Set fill-in elements in column JJ+KV to zero * IF( JJ+KV.LE.N ) THEN DO 70 I = 1, KL AB( I, JJ+KV ) = ZERO 70 CONTINUE END IF * * Find pivot and test for singularity. KM is the number of * subdiagonal elements in the current column. * KM = MIN( KL, M-JJ ) JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 ) IPIV( JJ ) = JP + JJ - J IF( AB( KV+JP, JJ ).NE.ZERO ) THEN JU = MAX( JU, MIN( JJ+KU+JP-1, N ) ) IF( JP.NE.1 ) THEN * * Apply interchange to columns J to J+JB-1 * IF( JP+JJ-1.LT.J+KL ) THEN * CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, $ AB( KV+JP+JJ-J, J ), LDAB-1 ) ELSE * * The interchange affects columns J to JJ-1 of A31 * which are stored in the work array WORK31 * CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, $ AB( KV+JP, JJ ), LDAB-1 ) END IF END IF * * Compute multipliers * CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), $ 1 ) * * Update trailing submatrix within the band and within * the current block. JM is the index of the last column * which needs to be updated. * JM = MIN( JU, J+JB-1 ) IF( JM.GT.JJ ) $ CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, $ AB( KV, JJ+1 ), LDAB-1, $ AB( KV+1, JJ+1 ), LDAB-1 ) ELSE * * If pivot is zero, set INFO to the index of the pivot * unless a zero pivot has already been found. * IF( INFO.EQ.0 ) $ INFO = JJ END IF * * Copy current column of A31 into the work array WORK31 * NW = MIN( JJ-J+1, I3 ) IF( NW.GT.0 ) $ CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, $ WORK31( 1, JJ-J+1 ), 1 ) 80 CONTINUE IF( J+JB.LE.N ) THEN * * Apply the row interchanges to the other blocks. * J2 = MIN( JU-J+1, KV ) - JB J3 = MAX( 0, JU-J-KV+1 ) * * Use DLASWP to apply the row interchanges to A12, A22, and * A32. * CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, $ IPIV( J ), 1 ) * * Adjust the pivot indices. * DO 90 I = J, J + JB - 1 IPIV( I ) = IPIV( I ) + J - 1 90 CONTINUE * * Apply the row interchanges to A13, A23, and A33 * columnwise. * K2 = J - 1 + JB + J2 DO 110 I = 1, J3 JJ = K2 + I DO 100 II = J + I - 1, J + JB - 1 IP = IPIV( II ) IF( IP.NE.II ) THEN TEMP = AB( KV+1+II-JJ, JJ ) AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ ) AB( KV+1+IP-JJ, JJ ) = TEMP END IF 100 CONTINUE 110 CONTINUE * * Update the relevant part of the trailing submatrix * IF( J2.GT.0 ) THEN * * Update A12 * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', $ JB, J2, ONE, AB( KV+1, J ), LDAB-1, $ AB( KV+1-JB, J+JB ), LDAB-1 ) * IF( I2.GT.0 ) THEN * * Update A22 * CALL DGEMM( 'No transpose', 'No transpose', I2, J2, $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, $ AB( KV+1, J+JB ), LDAB-1 ) END IF * IF( I3.GT.0 ) THEN * * Update A32 * CALL DGEMM( 'No transpose', 'No transpose', I3, J2, $ JB, -ONE, WORK31, LDWORK, $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, $ AB( KV+KL+1-JB, J+JB ), LDAB-1 ) END IF END IF * IF( J3.GT.0 ) THEN * * Copy the lower triangle of A13 into the work array * WORK13 * DO 130 JJ = 1, J3 DO 120 II = JJ, JB WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 ) 120 CONTINUE 130 CONTINUE * * Update A13 in the work array * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', $ JB, J3, ONE, AB( KV+1, J ), LDAB-1, $ WORK13, LDWORK ) * IF( I2.GT.0 ) THEN * * Update A23 * CALL DGEMM( 'No transpose', 'No transpose', I2, J3, $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), $ LDAB-1 ) END IF * IF( I3.GT.0 ) THEN * * Update A33 * CALL DGEMM( 'No transpose', 'No transpose', I3, J3, $ JB, -ONE, WORK31, LDWORK, WORK13, $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 ) END IF * * Copy the lower triangle of A13 back into place * DO 150 JJ = 1, J3 DO 140 II = JJ, JB AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ ) 140 CONTINUE 150 CONTINUE END IF ELSE * * Adjust the pivot indices. * DO 160 I = J, J + JB - 1 IPIV( I ) = IPIV( I ) + J - 1 160 CONTINUE END IF * * Partially undo the interchanges in the current block to * restore the upper triangular form of A31 and copy the upper * triangle of A31 back into place * DO 170 JJ = J + JB - 1, J, -1 JP = IPIV( JJ ) - JJ + 1 IF( JP.NE.1 ) THEN * * Apply interchange to columns J to JJ-1 * IF( JP+JJ-1.LT.J+KL ) THEN * * The interchange does not affect A31 * CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ AB( KV+JP+JJ-J, J ), LDAB-1 ) ELSE * * The interchange does affect A31 * CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) END IF END IF * * Copy the current column of A31 back into place * NW = MIN( I3, JJ-J+1 ) IF( NW.GT.0 ) $ CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1, $ AB( KV+KL+1-JJ+J, JJ ), 1 ) 170 CONTINUE 180 CONTINUE END IF * RETURN * * End of DGBTRF * END SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * Purpose * ======= * * DGBTRS solves a system of linear equations * A * X = B or A' * X = B * with a general band matrix A using the LU factorization computed * by DGBTRF. * * Arguments * ========= * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations. * = 'N': A * X = B (No transpose) * = 'T': A'* X = B (Transpose) * = 'C': A'* X = B (Conjugate transpose = Transpose) * * N (input) INTEGER * The order of the matrix A. N >= 0. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * AB (input) DOUBLE PRECISION array, dimension (LDAB,N) * Details of the LU factorization of the band matrix A, as * computed by DGBTRF. U is stored as an upper triangular band * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and * the multipliers used during the factorization are stored in * rows KL+KU+2 to 2*KL+KU+1. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= N, row i of the matrix was * interchanged with row IPIV(i). * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LNOTI, NOTRAN INTEGER I, J, KD, L, LM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER, DSWAP, DTBSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) THEN INFO = -5 ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGBTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * KD = KU + KL + 1 LNOTI = KL.GT.0 * IF( NOTRAN ) THEN * * Solve A*X = B. * * Solve L*X = B, overwriting B with X. * * L is represented as a product of permutations and unit lower * triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), * where each transformation L(i) is a rank-one modification of * the identity matrix. * IF( LNOTI ) THEN DO 10 J = 1, N - 1 LM = MIN( KL, N-J ) L = IPIV( J ) IF( L.NE.J ) $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), $ LDB, B( J+1, 1 ), LDB ) 10 CONTINUE END IF * DO 20 I = 1, NRHS * * Solve U*X = B, overwriting B with X. * CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, $ AB, LDAB, B( 1, I ), 1 ) 20 CONTINUE * ELSE * * Solve A'*X = B. * DO 30 I = 1, NRHS * * Solve U'*X = B, overwriting B with X. * CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, $ LDAB, B( 1, I ), 1 ) 30 CONTINUE * * Solve L'*X = B, overwriting B with X. * IF( LNOTI ) THEN DO 40 J = N - 1, 1, -1 LM = MIN( KL, N-J ) CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) L = IPIV( J ) IF( L.NE.J ) $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 40 CONTINUE END IF END IF RETURN * * End of DGBTRS * END SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. DOUBLE PRECISION SCALE( * ), V( LDV, * ) * .. * * Purpose * ======= * * DGEBAK forms the right or left eigenvectors of a real general matrix * by backward transformation on the computed eigenvectors of the * balanced matrix output by DGEBAL. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies the type of backward transformation required: * = 'N', do nothing, return immediately; * = 'P', do backward transformation for permutation only; * = 'S', do backward transformation for scaling only; * = 'B', do backward transformations for both permutation and * scaling. * JOB must be the same as the argument JOB supplied to DGEBAL. * * SIDE (input) CHARACTER*1 * = 'R': V contains right eigenvectors; * = 'L': V contains left eigenvectors. * * N (input) INTEGER * The number of rows of the matrix V. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * The integers ILO and IHI determined by DGEBAL. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * SCALE (input) DOUBLE PRECISION array, dimension (N) * Details of the permutation and scaling factors, as returned * by DGEBAL. * * M (input) INTEGER * The number of columns of the matrix V. M >= 0. * * V (input/output) DOUBLE PRECISION array, dimension (LDV,M) * On entry, the matrix of right or left eigenvectors to be * transformed, as returned by DHSEIN or DTREVC. * On exit, V is overwritten by the transformed eigenvectors. * * LDV (input) INTEGER * The leading dimension of the array V. LDV >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, II, K DOUBLE PRECISION S * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Decode and Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -7 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * IF( RIGHTV ) THEN DO 10 I = ILO, IHI S = SCALE( I ) CALL DSCAL( M, S, V( I, 1 ), LDV ) 10 CONTINUE END IF * IF( LEFTV ) THEN DO 20 I = ILO, IHI S = ONE / SCALE( I ) CALL DSCAL( M, S, V( I, 1 ), LDV ) 20 CONTINUE END IF * END IF * * Backward permutation * * For I = ILO-1 step -1 until 1, * IHI+1 step 1 until N do -- * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN IF( RIGHTV ) THEN DO 40 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 40 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 40 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE END IF * IF( LEFTV ) THEN DO 50 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 50 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 50 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 50 CONTINUE END IF END IF * RETURN * * End of DGEBAK * END SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER JOB INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), SCALE( * ) * .. * * Purpose * ======= * * DGEBAL balances a general real matrix A. This involves, first, * permuting A by a similarity transformation to isolate eigenvalues * in the first 1 to ILO-1 and last IHI+1 to N elements on the * diagonal; and second, applying a diagonal similarity transformation * to rows and columns ILO to IHI to make the rows and columns as * close in norm as possible. Both steps are optional. * * Balancing may reduce the 1-norm of the matrix, and improve the * accuracy of the computed eigenvalues and/or eigenvectors. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies the operations to be performed on A: * = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 * for i = 1,...,N; * = 'P': permute only; * = 'S': scale only; * = 'B': both permute and scale. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the input matrix A. * On exit, A is overwritten by the balanced matrix. * If JOB = 'N', A is not referenced. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * ILO (output) INTEGER * IHI (output) INTEGER * ILO and IHI are set to integers such that on exit * A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. * If JOB = 'N' or 'S', ILO = 1 and IHI = N. * * SCALE (output) DOUBLE PRECISION array, dimension (N) * Details of the permutations and scaling factors applied to * A. If P(j) is the index of the row and column interchanged * with row and column j and D(j) is the scaling factor * applied to row and column j, then * SCALE(j) = P(j) for j = 1,...,ILO-1 * = D(j) for j = ILO,...,IHI * = P(j) for j = IHI+1,...,N. * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The permutations consist of row and column interchanges which put * the matrix in the form * * ( T1 X Y ) * P A P = ( 0 B Z ) * ( 0 0 T2 ) * * where T1 and T2 are upper triangular matrices whose eigenvalues lie * along the diagonal. The column indices ILO and IHI mark the starting * and ending columns of the submatrix B. Balancing consists of applying * a diagonal similarity transformation inv(D) * B * D to make the * 1-norms of each row of B and its corresponding column nearly equal. * The output matrix is * * ( T1 X*D Y ) * ( 0 inv(D)*B*D inv(D)*Z ). * ( 0 0 T2 ) * * Information about the permutations P and the diagonal matrix D is * returned in the vector SCALE. * * This subroutine is based on the EISPACK routine BALANC. * * Modified by Tzu-Yi Chen, Computer Science Division, University of * California at Berkeley, USA * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC PARAMETER ( SCLFAC = 2.0D+0 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * .. * .. Local Scalars .. LOGICAL NOCONV INTEGER I, ICA, IEXC, IRA, J, K, L, M DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, $ SFMIN2 * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) 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( 'DGEBAL', -INFO ) RETURN END IF * K = 1 L = N * IF( N.EQ.0 ) $ GO TO 210 * IF( LSAME( JOB, 'N' ) ) THEN DO 10 I = 1, N SCALE( I ) = ONE 10 CONTINUE GO TO 210 END IF * IF( LSAME( JOB, 'S' ) ) $ GO TO 120 * * Permutation to isolate eigenvalues if possible * GO TO 50 * * Row and column exchange. * 20 CONTINUE SCALE( M ) = J IF( J.EQ.M ) $ GO TO 30 * CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL DSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) * 30 CONTINUE GO TO ( 40, 80 )IEXC * * Search for rows isolating an eigenvalue and push them down. * 40 CONTINUE IF( L.EQ.1 ) $ GO TO 210 L = L - 1 * 50 CONTINUE DO 70 J = L, 1, -1 * DO 60 I = 1, L IF( I.EQ.J ) $ GO TO 60 IF( A( J, I ).NE.ZERO ) $ GO TO 70 60 CONTINUE * M = L IEXC = 1 GO TO 20 70 CONTINUE * GO TO 90 * * Search for columns isolating an eigenvalue and push them left. * 80 CONTINUE K = K + 1 * 90 CONTINUE DO 110 J = K, L * DO 100 I = K, L IF( I.EQ.J ) $ GO TO 100 IF( A( I, J ).NE.ZERO ) $ GO TO 110 100 CONTINUE * M = K IEXC = 2 GO TO 20 110 CONTINUE * 120 CONTINUE DO 130 I = K, L SCALE( I ) = ONE 130 CONTINUE * IF( LSAME( JOB, 'P' ) ) $ GO TO 210 * * Balance the submatrix in rows K to L. * * Iterative loop for norm reduction * SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 140 CONTINUE NOCONV = .FALSE. * DO 200 I = K, L C = ZERO R = ZERO * DO 150 J = K, L IF( J.EQ.I ) $ GO TO 150 C = C + ABS( A( J, I ) ) R = R + ABS( A( I, J ) ) 150 CONTINUE ICA = IDAMAX( L, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = IDAMAX( N-K+1, A( I, K ), LDA ) RA = ABS( A( I, IRA+K-1 ) ) * * Guard against zero C or R due to underflow. * IF( C.EQ.ZERO .OR. R.EQ.ZERO ) $ GO TO 200 G = R / SCLFAC F = ONE S = C + R 160 CONTINUE IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 F = F*SCLFAC C = C*SCLFAC CA = CA*SCLFAC R = R / SCLFAC G = G / SCLFAC RA = RA / SCLFAC GO TO 160 * 170 CONTINUE G = C / SCLFAC 180 CONTINUE IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 F = F / SCLFAC C = C / SCLFAC G = G / SCLFAC CA = CA / SCLFAC R = R*SCLFAC RA = RA*SCLFAC GO TO 180 * * Now balance. * 190 CONTINUE IF( ( C+R ).GE.FACTOR*S ) $ GO TO 200 IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN IF( F*SCALE( I ).LE.SFMIN1 ) $ GO TO 200 END IF IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN IF( SCALE( I ).GE.SFMAX1 / F ) $ GO TO 200 END IF G = ONE / F SCALE( I ) = SCALE( I )*F NOCONV = .TRUE. * CALL DSCAL( N-K+1, G, A( I, K ), LDA ) CALL DSCAL( L, F, A( 1, I ), 1 ) * 200 CONTINUE * IF( NOCONV ) $ GO TO 140 * 210 CONTINUE ILO = K IHI = L * RETURN * * End of DGEBAL * END SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), $ TAUQ( * ), WORK( * ) * .. * * Purpose * ======= * * DGEBD2 reduces a real general m by n matrix A to upper or lower * bidiagonal form B by an orthogonal transformation: Q' * A * P = B. * * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. * * Arguments * ========= * * M (input) INTEGER * The number of rows in the matrix A. M >= 0. * * N (input) INTEGER * The number of columns in the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the m by n general matrix to be reduced. * On exit, * if m >= n, the diagonal and the first superdiagonal are * overwritten with the upper bidiagonal matrix B; the * elements below the diagonal, with the array TAUQ, represent * the orthogonal matrix Q as a product of elementary * reflectors, and the elements above the first superdiagonal, * with the array TAUP, represent the orthogonal matrix P as * a product of elementary reflectors; * if m < n, the diagonal and the first subdiagonal are * overwritten with the lower bidiagonal matrix B; the * elements below the first subdiagonal, with the array TAUQ, * represent the orthogonal matrix Q as a product of * elementary reflectors, and the elements above the diagonal, * with the array TAUP, represent the orthogonal matrix P as * a product of elementary reflectors. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * D (output) DOUBLE PRECISION array, dimension (min(M,N)) * The diagonal elements of the bidiagonal matrix B: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) * The off-diagonal elements of the bidiagonal matrix B: * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. * * TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the orthogonal matrix Q. See Further Details. * * TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the orthogonal matrix P. See Further Details. * * WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The matrices Q and P are represented as products of elementary * reflectors: * * If m >= n, * * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are real scalars, and v and u are real vectors; * v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); * u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); * tauq is stored in TAUQ(i) and taup in TAUP(i). * * If m < n, * * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are real scalars, and v and u are real vectors; * v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); * u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); * tauq is stored in TAUQ(i) and taup in TAUP(i). * * The contents of A on exit are illustrated by the following examples: * * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): * * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) * ( v1 v2 v3 v4 v5 ) * * where d and e denote diagonal and off-diagonal elements of B, vi * denotes an element of the vector defining H(i), and ui an element of * the vector defining G(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, 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.LT.0 ) THEN CALL XERBLA( 'DGEBD2', -INFO ) RETURN END IF * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, N * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = A( I, I ) A( I, I ) = ONE * * Apply H(i) to A(i:m,i+1:n) from the left * IF( I.LT.N ) $ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), $ A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN * * Generate elementary reflector G(i) to annihilate * A(i,i+2:n) * CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), $ LDA, TAUP( I ) ) E( I ) = A( I, I+1 ) A( I, I+1 ) = ONE * * Apply G(i) to A(i+1:m,i+1:n) from the right * CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) A( I, I+1 ) = E( I ) ELSE TAUP( I ) = ZERO END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, M * * Generate elementary reflector G(i) to annihilate A(i,i+1:n) * CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = A( I, I ) A( I, I ) = ONE * * Apply G(i) to A(i+1:m,i:n) from the right * IF( I.LT.M ) $ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, $ TAUP( I ), A( I+1, I ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.M ) THEN * * Generate elementary reflector H(i) to annihilate * A(i+2:m,i) * CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = A( I+1, I ) A( I+1, I ) = ONE * * Apply H(i) to A(i+1:m,i+1:n) from the left * CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ), $ A( I+1, I+1 ), LDA, WORK ) A( I+1, I ) = E( I ) ELSE TAUQ( I ) = ZERO END IF 20 CONTINUE END IF RETURN * * End of DGEBD2 * END SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), $ TAUQ( * ), WORK( * ) * .. * * Purpose * ======= * * DGEBRD reduces a general real M-by-N matrix A to upper or lower * bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. * * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. * * Arguments * ========= * * M (input) INTEGER * The number of rows in the matrix A. M >= 0. * * N (input) INTEGER * The number of columns in the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the M-by-N general matrix to be reduced. * On exit, * if m >= n, the diagonal and the first superdiagonal are * overwritten with the upper bidiagonal matrix B; the * elements below the diagonal, with the array TAUQ, represent * the orthogonal matrix Q as a product of elementary * reflectors, and the elements above the first superdiagonal, * with the array TAUP, represent the orthogonal matrix P as * a product of elementary reflectors; * if m < n, the diagonal and the first subdiagonal are * overwritten with the lower bidiagonal matrix B; the * elements below the first subdiagonal, with the array TAUQ, * represent the orthogonal matrix Q as a product of * elementary reflectors, and the elements above the diagonal, * with the array TAUP, represent the orthogonal matrix P as * a product of elementary reflectors. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * D (output) DOUBLE PRECISION array, dimension (min(M,N)) * The diagonal elements of the bidiagonal matrix B: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) * The off-diagonal elements of the bidiagonal matrix B: * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. * * TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the orthogonal matrix Q. See Further Details. * * TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the orthogonal matrix P. 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 length of the array WORK. LWORK >= max(1,M,N). * For optimum performance LWORK >= (M+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 * =============== * * The matrices Q and P are represented as products of elementary * reflectors: * * If m >= n, * * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are real scalars, and v and u are real vectors; * v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); * u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); * tauq is stored in TAUQ(i) and taup in TAUP(i). * * If m < n, * * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are real scalars, and v and u are real vectors; * v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); * u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); * tauq is stored in TAUQ(i) and taup in TAUP(i). * * The contents of A on exit are illustrated by the following examples: * * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): * * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) * ( v1 v2 v3 v4 v5 ) * * where d and e denote diagonal and off-diagonal elements of B, vi * denotes an element of the vector defining H(i), and ui an element of * the vector defining G(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, $ NBMIN, NX DOUBLE PRECISION WS * .. * .. External Subroutines .. EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) ) LWKOPT = ( M+N )*NB WORK( 1 ) = DBLE( LWKOPT ) LQUERY = ( LWORK.EQ.-1 ) 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 ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN INFO = -10 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'DGEBRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * WS = MAX( M, N ) LDWRKX = M LDWRKY = N * IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN * * Set the crossover point NX. * NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) ) * * Determine when to switch from blocked to unblocked code. * IF( NX.LT.MINMN ) THEN WS = ( M+N )*NB IF( LWORK.LT.WS ) THEN * * Not enough work space for the optimal NB, consider using * a smaller block size. * NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 ) IF( LWORK.GE.( M+N )*NBMIN ) THEN NB = LWORK / ( M+N ) ELSE NB = 1 NX = MINMN END IF END IF END IF ELSE NX = MINMN END IF * DO 30 I = 1, MINMN - NX, NB * * Reduce rows and columns i:i+nb-1 to bidiagonal form and return * the matrices X and Y which are needed to update the unreduced * part of the matrix * CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, $ WORK( LDWRKX*NB+1 ), LDWRKY ) * * Update the trailing submatrix A(i+nb:m,i+nb:n), using an update * of the form A := A - V*Y' - X*U' * CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1, $ NB, -ONE, A( I+NB, I ), LDA, $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, $ A( I+NB, I+NB ), LDA ) CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, $ ONE, A( I+NB, I+NB ), LDA ) * * Copy diagonal and off-diagonal elements of B back into A * IF( M.GE.N ) THEN DO 10 J = I, I + NB - 1 A( J, J ) = D( J ) A( J, J+1 ) = E( J ) 10 CONTINUE ELSE DO 20 J = I, I + NB - 1 A( J, J ) = D( J ) A( J+1, J ) = E( J ) 20 CONTINUE END IF 30 CONTINUE * * Use unblocked code to reduce the remainder of the matrix * CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), $ TAUQ( I ), TAUP( I ), WORK, IINFO ) WORK( 1 ) = WS RETURN * * End of DGEBRD * END SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER NORM INTEGER INFO, LDA, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * DGECON estimates the reciprocal of the condition number of a general * real matrix A, in either the 1-norm or the infinity-norm, using * the LU factorization computed by DGETRF. * * An estimate is obtained for norm(inv(A)), and the reciprocal of the * condition number is computed as * RCOND = 1 / ( norm(A) * norm(inv(A)) ). * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies whether the 1-norm condition number or the * infinity-norm condition number is required: * = '1' or 'O': 1-norm; * = 'I': Infinity-norm. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The factors L and U from the factorization A = P*L*U * as computed by DGETRF. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * ANORM (input) DOUBLE PRECISION * If NORM = '1' or 'O', the 1-norm of the original matrix A. * If NORM = 'I', the infinity-norm of the original matrix A. * * RCOND (output) DOUBLE PRECISION * The reciprocal of the condition number of the matrix A, * computed as RCOND = 1/(norm(A) * norm(inv(A))). * * WORK (workspace) DOUBLE PRECISION array, dimension (4*N) * * IWORK (workspace) INTEGER array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL ONENRM CHARACTER NORMIN INTEGER IX, KASE, KASE1 DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( ANORM.LT.ZERO ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGECON', -INFO ) RETURN END IF * * Quick return if possible * RCOND = ZERO IF( N.EQ.0 ) THEN RCOND = ONE RETURN ELSE IF( ANORM.EQ.ZERO ) THEN RETURN END IF * SMLNUM = DLAMCH( 'Safe minimum' ) * * Estimate the norm of inv(A). * AINVNM = ZERO NORMIN = 'N' IF( ONENRM ) THEN KASE1 = 1 ELSE KASE1 = 2 END IF KASE = 0 10 CONTINUE CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * * Multiply by inv(L). * CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A, $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) * * Multiply by inv(U). * CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, $ A, LDA, WORK, SU, WORK( 3*N+1 ), INFO ) ELSE * * Multiply by inv(U'). * CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, $ LDA, WORK, SU, WORK( 3*N+1 ), INFO ) * * Multiply by inv(L'). * CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A, $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) END IF * * Divide X by 1/(SL*SU) if doing so will not cause overflow. * SCALE = SL*SU NORMIN = 'Y' IF( SCALE.NE.ONE ) THEN IX = IDAMAX( N, WORK, 1 ) IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) $ GO TO 20 CALL DRSCL( N, SCALE, WORK, 1 ) END IF GO TO 10 END IF * * Compute the estimate of the reciprocal condition number. * IF( AINVNM.NE.ZERO ) $ RCOND = ( ONE / AINVNM ) / ANORM * 20 CONTINUE RETURN * * End of DGECON * END SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) * .. * * Purpose * ======= * * DGEEQU computes row and column scalings intended to equilibrate an * M-by-N matrix A and reduce its condition number. R returns the row * scale factors and C the column scale factors, chosen to try to make * the largest element in each row and column of the matrix B with * elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. * * R(i) and C(j) are restricted to be between SMLNUM = smallest safe * number and BIGNUM = largest safe number. Use of these scaling * factors is not guaranteed to reduce the condition number of A but * works well in practice. * * 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) DOUBLE PRECISION array, dimension (LDA,N) * The M-by-N matrix whose equilibration factors are * to be computed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * R (output) DOUBLE PRECISION array, dimension (M) * If INFO = 0 or INFO > M, R contains the row scale factors * for A. * * C (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, C contains the column scale factors for A. * * ROWCND (output) DOUBLE PRECISION * If INFO = 0 or INFO > M, ROWCND contains the ratio of the * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and * AMAX is neither too large nor too small, it is not worth * scaling by R. * * COLCND (output) DOUBLE PRECISION * If INFO = 0, COLCND contains the ratio of the smallest * C(i) to the largest C(i). If COLCND >= 0.1, it is not * worth scaling by C. * * AMAX (output) DOUBLE PRECISION * Absolute value of largest matrix element. If AMAX is very * close to overflow or very close to underflow, the matrix * should be scaled. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, and i is * <= M: the i-th row of A is exactly zero * > M: the (i-M)-th column of A is exactly zero * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, 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( 'DGEEQU', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN ROWCND = ONE COLCND = ONE AMAX = ZERO RETURN END IF * * Get machine constants. * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * * Compute row scale factors. * DO 10 I = 1, M R( I ) = ZERO 10 CONTINUE * * Find the maximum element in each row. * DO 30 J = 1, N DO 20 I = 1, M R( I ) = MAX( R( I ), ABS( A( I, J ) ) ) 20 CONTINUE 30 CONTINUE * * Find the maximum and minimum scale factors. * RCMIN = BIGNUM RCMAX = ZERO DO 40 I = 1, M RCMAX = MAX( RCMAX, R( I ) ) RCMIN = MIN( RCMIN, R( I ) ) 40 CONTINUE AMAX = RCMAX * IF( RCMIN.EQ.ZERO ) THEN * * Find the first zero scale factor and return an error code. * DO 50 I = 1, M IF( R( I ).EQ.ZERO ) THEN INFO = I RETURN END IF 50 CONTINUE ELSE * * Invert the scale factors. * DO 60 I = 1, M R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) 60 CONTINUE * * Compute ROWCND = min(R(I)) / max(R(I)) * ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) END IF * * Compute column scale factors * DO 70 J = 1, N C( J ) = ZERO 70 CONTINUE * * Find the maximum element in each column, * assuming the row scaling computed above. * DO 90 J = 1, N DO 80 I = 1, M C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) ) 80 CONTINUE 90 CONTINUE * * Find the maximum and minimum scale factors. * RCMIN = BIGNUM RCMAX = ZERO DO 100 J = 1, N RCMIN = MIN( RCMIN, C( J ) ) RCMAX = MAX( RCMAX, C( J ) ) 100 CONTINUE * IF( RCMIN.EQ.ZERO ) THEN * * Find the first zero scale factor and return an error code. * DO 110 J = 1, N IF( C( J ).EQ.ZERO ) THEN INFO = M + J RETURN END IF 110 CONTINUE ELSE * * Invert the scale factors. * DO 120 J = 1, N C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) 120 CONTINUE * * Compute COLCND = min(C(J)) / max(C(J)) * COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) END IF * RETURN * * End of DGEEQU * END SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEHD2 reduces a real general matrix A to upper Hessenberg form H by * an orthogonal similarity transformation: Q' * A * Q = H . * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that A is already upper triangular in rows * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally * set by a previous call to DGEBAL; otherwise they should be * set to 1 and N respectively. See Further Details. * 1 <= ILO <= IHI <= max(1,N). * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the n by n general matrix to be reduced. * On exit, the upper triangle and the first subdiagonal of A * are overwritten with the upper Hessenberg matrix H, 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). * * TAU (output) DOUBLE PRECISION array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). * * 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. * * Further Details * =============== * * The matrix Q is represented as a product of (ihi-ilo) elementary * reflectors * * Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on * exit in A(i+2:ihi,i), and tau in TAU(i). * * The contents of A are illustrated by the following example, with * n = 7, ilo = 2 and ihi = 6: * * on entry, on exit, * * ( a a a a a a a ) ( a a h h h h a ) * ( a a a a a a ) ( a h h h h a ) * ( a a a a a a ) ( h h h h h h ) * ( a a a a a a ) ( v2 h h h h h ) * ( a a a a a a ) ( v2 v3 h h h h ) * ( a a a a a a ) ( v2 v3 v4 h h h ) * ( a ) ( a ) * * where a denotes an element of the original matrix A, h denotes a * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEHD2', -INFO ) RETURN END IF * DO 10 I = ILO, IHI - 1 * * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) * CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, $ TAU( I ) ) AII = A( I+1, I ) A( I+1, I ) = ONE * * Apply H(i) to A(1:ihi,i+1:ihi) from the right * CALL DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), $ A( 1, I+1 ), LDA, WORK ) * * Apply H(i) to A(i+1:ihi,i+1:n) from the left * CALL DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), $ A( I+1, I+1 ), LDA, WORK ) * A( I+1, I ) = AII 10 CONTINUE * RETURN * * End of DGEHD2 * END SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEHRD reduces a real general matrix A to upper Hessenberg form H by * an orthogonal similarity transformation: Q' * A * Q = H . * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that A is already upper triangular in rows * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally * set by a previous call to DGEBAL; otherwise they should be * set to 1 and N respectively. See Further Details. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the N-by-N general matrix to be reduced. * On exit, the upper triangle and the first subdiagonal of A * are overwritten with the upper Hessenberg matrix H, 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). * * TAU (output) DOUBLE PRECISION array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to * zero. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,N). * 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 * =============== * * The matrix Q is represented as a product of (ihi-ilo) elementary * reflectors * * Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on * exit in A(i+2:ihi,i), and tau in TAU(i). * * The contents of A are illustrated by the following example, with * n = 7, ilo = 2 and ihi = 6: * * on entry, on exit, * * ( a a a a a a a ) ( a a h h h h a ) * ( a a a a a a ) ( a h h h h a ) * ( a a a a a a ) ( h h h h h h ) * ( a a a a a a ) ( v2 h h h h h ) * ( a a a a a a ) ( v2 v3 h h h h ) * ( a a a a a a ) ( v2 v3 v4 h h h ) * ( a ) ( a ) * * where a denotes an element of the original matrix A, h denotes a * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * * This file is a slight modification of LAPACK-3.0's DGEHRD * subroutine incorporating improvements proposed by Quintana-Orti and * Van de Geijn (2005). * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, $ ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB, $ NBMIN, NH, NX DOUBLE PRECISION EI * .. * .. Local Arrays .. DOUBLE PRECISION T( LDT, NBMAX ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DGEHD2, DGEMM, DLAHR2, DLARFB, DTRMM, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) LWKOPT = N*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEHRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Set elements 1:ILO-1 and IHI:N-1 of TAU to zero * DO 10 I = 1, ILO - 1 TAU( I ) = ZERO 10 CONTINUE DO 20 I = MAX( 1, IHI ), N - 1 TAU( I ) = ZERO 20 CONTINUE * * Quick return if possible * NH = IHI - ILO + 1 IF( NH.LE.1 ) THEN WORK( 1 ) = 1 RETURN END IF * * Determine the block size * NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) NBMIN = 2 IWS = 1 IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code * (last block is always handled by unblocked code) * NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * * Determine if workspace is large enough for blocked code * IWS = N*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 * NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI, $ -1 ) ) IF( LWORK.GE.N*NBMIN ) THEN NB = LWORK / N ELSE NB = 1 END IF END IF END IF END IF LDWORK = N * IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN * * Use unblocked code below * I = ILO * ELSE * * Use blocked code * DO 40 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V' * which performs the reduction, and also the matrix Y = A*V*T * CALL DLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, $ WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V'. V(i+ib,ib-1) must be set * to 1 * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE CALL DGEMM( 'No transpose', 'Transpose', $ IHI, IHI-I-IB+1, $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, $ A( 1, I+IB ), LDA ) A( I+IB, I+IB-1 ) = EI * * Apply the block reflector H to A(1:i,i+1:i+ib-1) from the * right * CALL DTRMM( 'Right', 'Lower', 'Transpose', $ 'Unit', I, IB-1, $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) DO 30 J = 0, IB-2 CALL DAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, $ A( 1, I+J+1 ), 1 ) 30 CONTINUE * * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, $ A( I+1, I+IB ), LDA, WORK, LDWORK ) 40 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix * CALL DGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) WORK( 1 ) = IWS * RETURN * * End of DGEHRD * END SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGELQ2 computes an LQ factorization of a real m by n matrix A: * A = L * Q. * * 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 A. * On exit, the elements on and below the diagonal of the array * contain the m by min(m,n) lower trapezoidal matrix L (L is * lower triangular if m <= n); the elements above 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 >= max(1,M). * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) DOUBLE PRECISION array, dimension (M) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(k) . . . H(2) H(1), where k = min(m,n). * * 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-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), * and tau in TAU(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * 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( 'DGELQ2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i,i+1:n) * CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, $ TAU( I ) ) IF( I.LT.M ) THEN * * Apply H(i) to A(i+1:m,i:n) from the right * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), $ A( I+1, I ), LDA, WORK ) A( I, I ) = AII END IF 10 CONTINUE RETURN * * End of DGELQ2 * END SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGELQF computes an LQ factorization of a real M-by-N matrix A: * A = L * Q. * * 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 A. * On exit, the elements on and below the diagonal of the array * contain the m-by-min(m,n) lower trapezoidal matrix L (L is * lower triangular if m <= n); the elements above 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 >= max(1,M). * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * 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 >= max(1,M). * For optimum performance LWORK >= M*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 * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(k) . . . H(2) H(1), where k = min(m,n). * * 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-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), * and tau in TAU(i). * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) LWKOPT = M*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) 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 ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELQF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the LQ factorization of the current block * A(i:i+ib-1,i:n) * CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.M ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i+ib:m,i:n) from the right * CALL DLARFB( 'Right', 'No transpose', 'Forward', $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, $ WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE ELSE I = 1 END IF * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of DGELQF * END SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEQL2 computes a QL factorization of a real m by n matrix A: * A = Q * L. * * 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 A. * On exit, if m >= n, the lower triangle of the subarray * A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; * if m <= n, the elements on and below the (n-m)-th * superdiagonal contain the m by n lower trapezoidal matrix L; * the remaining elements, 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,M). * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * 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 * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(k) . . . H(2) H(1), where k = min(m,n). * * 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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in * A(1:m-k+i-1,n-k+i), and tau in TAU(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * 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( 'DGEQL2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = K, 1, -1 * * Generate elementary reflector H(i) to annihilate * A(1:m-k+i-1,n-k+i) * CALL DLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 1, $ TAU( I ) ) * * Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left * AII = A( M-K+I, N-K+I ) A( M-K+I, N-K+I ) = ONE CALL DLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, TAU( I ), $ A, LDA, WORK ) A( M-K+I, N-K+I ) = AII 10 CONTINUE RETURN * * End of DGEQL2 * END SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEQLF computes a QL factorization of a real M-by-N matrix A: * A = Q * L. * * 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 A. * On exit, * if m >= n, the lower triangle of the subarray * A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L; * if m <= n, the elements on and below the (n-m)-th * superdiagonal contain the M-by-N lower trapezoidal matrix L; * the remaining elements, 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,M). * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * 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 >= max(1,N). * 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 * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(k) . . . H(2) H(1), where k = min(m,n). * * 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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in * A(1:m-k+i-1,n-k+i), and tau in TAU(i). * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT, $ MU, NB, NBMIN, NU, NX * .. * .. External Subroutines .. EXTERNAL DGEQL2, DLARFB, DLARFT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) 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.EQ.0 ) THEN K = MIN( M, N ) IF( K.EQ.0 ) THEN LWKOPT = 1 ELSE NB = ILAENV( 1, 'DGEQLF', ' ', M, N, -1, -1 ) LWKOPT = N*NB END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQLF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( K.EQ.0 ) THEN RETURN END IF * NBMIN = 2 NX = 1 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DGEQLF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DGEQLF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially. * The last kk columns are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * DO 10 I = K - KK + KI + 1, K - KK + 1, -NB IB = MIN( K-I+1, NB ) * * Compute the QL factorization of the current block * A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1) * CALL DGEQL2( M-K+I+IB-1, IB, A( 1, N-K+I ), LDA, TAU( I ), $ WORK, IINFO ) IF( N-K+I.GT.1 ) THEN * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left * CALL DLARFB( 'Left', 'Transpose', 'Backward', $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, $ WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE MU = M - K + I + NB - 1 NU = N - K + I + NB - 1 ELSE MU = M NU = N END IF * * Use unblocked code to factor the last or only block * IF( MU.GT.0 .AND. NU.GT.0 ) $ CALL DGEQL2( MU, NU, A, LDA, TAU, WORK, IINFO ) * WORK( 1 ) = IWS RETURN * * End of DGEQLF * END SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEQP3 computes a QR factorization with column pivoting of a * matrix A: A*P = Q*R using Level 3 BLAS. * * 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 A. * On exit, the upper triangle of the array contains the * min(M,N)-by-N upper trapezoidal matrix R; the elements below * the diagonal, together with the array TAU, represent the * orthogonal matrix Q as a product of min(M,N) elementary * reflectors. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * JPVT (input/output) INTEGER array, dimension (N) * On entry, if JPVT(J).ne.0, the J-th column of A is permuted * to the front of A*P (a leading column); if JPVT(J)=0, * the J-th column of A is a free column. * On exit, if JPVT(J)=K, then the J-th column of A*P was the * the K-th column of A. * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors. * * 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 >= 3*N+1. * For optimal performance LWORK >= 2*N+( N+1 )*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 * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real/complex scalar, and v is a real/complex vector * with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in * A(i+1:m,i), and tau in TAU(i). * * Based on contributions by * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain * X. Sun, Computer Science Dept., Duke University, USA * * ===================================================================== * * .. Parameters .. INTEGER INB, INBMIN, IXOVER PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN * .. * .. External Subroutines .. EXTERNAL DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA * .. * .. External Functions .. INTEGER ILAENV DOUBLE PRECISION DNRM2 EXTERNAL ILAENV, DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * * Test input arguments * ==================== * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) 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.EQ.0 ) THEN MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN IWS = 1 LWKOPT = 1 ELSE IWS = 3*N + 1 NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) LWKOPT = 2*N + ( N + 1 )*NB END IF WORK( 1 ) = LWKOPT * IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQP3', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible. * IF( MINMN.EQ.0 ) THEN RETURN END IF * * Move initial columns up front. * NFXD = 1 DO 10 J = 1, N IF( JPVT( J ).NE.0 ) THEN IF( J.NE.NFXD ) THEN CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 ) JPVT( J ) = JPVT( NFXD ) JPVT( NFXD ) = J ELSE JPVT( J ) = J END IF NFXD = NFXD + 1 ELSE JPVT( J ) = J END IF 10 CONTINUE NFXD = NFXD - 1 * * Factorize fixed columns * ======================= * * Compute the QR factorization of fixed columns and update * remaining columns. * IF( NFXD.GT.0 ) THEN NA = MIN( M, NFXD ) *CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO ) IWS = MAX( IWS, INT( WORK( 1 ) ) ) IF( NA.LT.N ) THEN *CC CALL DORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA, *CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) CALL DORMQR( 'Left', 'Transpose', M, N-NA, NA, A, LDA, TAU, $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO ) IWS = MAX( IWS, INT( WORK( 1 ) ) ) END IF END IF * * Factorize free columns * ====================== * IF( NFXD.LT.MINMN ) THEN * SM = M - NFXD SN = N - NFXD SMINMN = MINMN - NFXD * * Determine the block size. * NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 ) NBMIN = 2 NX = 0 * IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1, $ -1 ) ) * * IF( NX.LT.SMINMN ) THEN * * Determine if workspace is large enough for blocked code. * MINWS = 2*SN + ( SN+1 )*NB IWS = MAX( IWS, MINWS ) IF( LWORK.LT.MINWS ) THEN * * Not enough workspace to use optimal NB: Reduce NB and * determine the minimum value of NB. * NB = ( LWORK-2*SN ) / ( SN+1 ) NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, SN, $ -1, -1 ) ) * * END IF END IF END IF * * Initialize partial column norms. The first N elements of work * store the exact column norms. * DO 20 J = NFXD + 1, N WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 ) WORK( N+J ) = WORK( J ) 20 CONTINUE * IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. $ ( NX.LT.SMINMN ) ) THEN * * Use blocked code initially. * J = NFXD + 1 * * Compute factorization: while loop. * * TOPBMN = MINMN - NX 30 CONTINUE IF( J.LE.TOPBMN ) THEN JB = MIN( NB, TOPBMN-J+1 ) * * Factorize JB columns among columns J:N. * CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 ) * J = J + FJB GO TO 30 END IF ELSE J = NFXD + 1 END IF * * Use unblocked code to factor the last or only block. * * IF( J.LE.MINMN ) $ CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), $ TAU( J ), WORK( J ), WORK( N+J ), $ WORK( 2*N+1 ) ) * END IF * WORK( 1 ) = IWS RETURN * * End of DGEQP3 * END SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * * -- LAPACK deprecated driver routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * This routine is deprecated and has been replaced by routine DGEQP3. * * DGEQPF computes a QR factorization with column pivoting of a * real M-by-N matrix A: A*P = Q*R. * * 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 A. * On exit, the upper triangle of the array contains the * min(M,N)-by-N upper triangular matrix R; the elements * below the diagonal, together with the array TAU, * represent the orthogonal matrix Q as a product of * min(m,n) elementary reflectors. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * JPVT (input/output) INTEGER array, dimension (N) * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted * to the front of A*P (a leading column); if JPVT(i) = 0, * the i-th column of A is a free column. * On exit, if JPVT(i) = k, then the i-th column of A*P * was the k-th column of A. * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors. * * WORK (workspace) DOUBLE PRECISION array, dimension (3*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(n) * * Each H(i) has the form * * H = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). * * The matrix P is represented in jpvt as follows: If * jpvt(j) = i * then the jth column of P is the ith canonical unit vector. * * Partial column norm updating strategy modified by * Z. Drmac and Z. Bujanovic, Dept. of Mathematics, * University of Zagreb, Croatia. * June 2006. * For more details see LAPACK Working Note 176. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL IDAMAX, DLAMCH, DNRM2 * .. * .. Executable Statements .. * * Test the input arguments * 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( 'DGEQPF', -INFO ) RETURN END IF * MN = MIN( M, N ) TOL3Z = SQRT(DLAMCH('Epsilon')) * * Move initial columns up front * ITEMP = 1 DO 10 I = 1, N IF( JPVT( I ).NE.0 ) THEN IF( I.NE.ITEMP ) THEN CALL DSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 ) JPVT( I ) = JPVT( ITEMP ) JPVT( ITEMP ) = I ELSE JPVT( I ) = I END IF ITEMP = ITEMP + 1 ELSE JPVT( I ) = I END IF 10 CONTINUE ITEMP = ITEMP - 1 * * Compute the QR factorization and update remaining columns * IF( ITEMP.GT.0 ) THEN MA = MIN( ITEMP, M ) CALL DGEQR2( M, MA, A, LDA, TAU, WORK, INFO ) IF( MA.LT.N ) THEN CALL DORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU, $ A( 1, MA+1 ), LDA, WORK, INFO ) END IF END IF * IF( ITEMP.LT.MN ) THEN * * Initialize partial column norms. The first n elements of * work store the exact column norms. * DO 20 I = ITEMP + 1, N WORK( I ) = DNRM2( M-ITEMP, A( ITEMP+1, I ), 1 ) WORK( N+I ) = WORK( I ) 20 CONTINUE * * Compute factorization * DO 40 I = ITEMP + 1, MN * * Determine ith pivot column and swap if necessary * PVT = ( I-1 ) + IDAMAX( N-I+1, WORK( I ), 1 ) * IF( PVT.NE.I ) THEN CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( I ) JPVT( I ) = ITEMP WORK( PVT ) = WORK( I ) WORK( N+PVT ) = WORK( N+I ) END IF * * Generate elementary reflector H(i) * IF( I.LT.M ) THEN CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) ELSE CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) ) END IF * IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK( 2*N+1 ) ) A( I, I ) = AII END IF * * Update partial column norms * DO 30 J = I + 1, N IF( WORK( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ABS( A( I, J ) ) / WORK( J ) TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) TEMP2 = TEMP*( WORK( J ) / WORK( N+J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN IF( M-I.GT.0 ) THEN WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J ) ELSE WORK( J ) = ZERO WORK( N+J ) = ZERO END IF ELSE WORK( J ) = WORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE * 40 CONTINUE END IF RETURN * * End of DGEQPF * END SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEQR2 computes a QR factorization of a real m by n matrix A: * A = Q * R. * * 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 A. * On exit, the elements on and above the diagonal of the array * contain the min(m,n) by n upper trapezoidal matrix R (R is * upper triangular if m >= n); 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 >= max(1,M). * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * 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 * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * 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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * 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( 'DGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF 10 CONTINUE RETURN * * End of DGEQR2 * END SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEQRF computes a QR factorization of a real M-by-N matrix A: * A = Q * R. * * 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 A. * On exit, the elements on and above the diagonal of the array * contain the min(M,N)-by-N upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the orthogonal matrix Q as a * product of min(m,n) elementary reflectors (see Further * Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * 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 >= max(1,N). * 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 * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * 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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) 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 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQRF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the QR factorization of the current block * A(i:m,i:i+ib-1) * CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H' to A(i:m,i+ib:n) from the left * CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE ELSE I = 1 END IF * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of DGEQRF * END SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. * * Purpose * ======= * * DGERFS improves the computed solution to a system of linear * equations and provides error bounds and backward error estimates for * the solution. * * Arguments * ========= * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations: * = 'N': A * X = B (No transpose) * = 'T': A**T * X = B (Transpose) * = 'C': A**H * X = B (Conjugate transpose = Transpose) * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrices B and X. NRHS >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The original N-by-N matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * AF (input) DOUBLE PRECISION array, dimension (LDAF,N) * The factors L and U from the factorization A = P*L*U * as computed by DGETRF. * * LDAF (input) INTEGER * The leading dimension of the array AF. LDAF >= max(1,N). * * IPIV (input) INTEGER array, dimension (N) * The pivot indices from DGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) * The right hand side matrix B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) * On entry, the solution matrix X, as computed by DGETRS. * On exit, the improved solution matrix X. * * LDX (input) INTEGER * The leading dimension of the array X. LDX >= max(1,N). * * FERR (output) DOUBLE PRECISION array, dimension (NRHS) * The estimated forward error bound for each solution vector * X(j) (the j-th column of the solution matrix X). * If XTRUE is the true solution corresponding to X(j), FERR(j) * is an estimated upper bound for the magnitude of the largest * element in (X(j) - XTRUE) divided by the magnitude of the * largest element in X(j). The estimate is as reliable as * the estimate for RCOND, and is almost always a slight * overestimate of the true error. * * BERR (output) DOUBLE PRECISION array, dimension (NRHS) * The componentwise relative backward error of each solution * vector X(j) (i.e., the smallest relative change in * any element of A or B that makes X(j) an exact solution). * * WORK (workspace) DOUBLE PRECISION array, dimension (3*N) * * IWORK (workspace) INTEGER array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Internal Parameters * =================== * * ITMAX is the maximum number of steps of iterative refinement. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D+0 ) DOUBLE PRECISION THREE PARAMETER ( THREE = 3.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN CHARACTER TRANST INTEGER COUNT, I, J, K, KASE, NZ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DGETRS, DLACN2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -12 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGERFS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN DO 10 J = 1, NRHS FERR( J ) = ZERO BERR( J ) = ZERO 10 CONTINUE RETURN END IF * IF( NOTRAN ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * * NZ = maximum number of nonzero elements in each row of A, plus 1 * NZ = N + 1 EPS = DLAMCH( 'Epsilon' ) SAFMIN = DLAMCH( 'Safe minimum' ) SAFE1 = NZ*SAFMIN SAFE2 = SAFE1 / EPS * * Do for each right hand side * DO 140 J = 1, NRHS * COUNT = 1 LSTRES = THREE 20 CONTINUE * * Loop until stopping criterion is satisfied. * * Compute residual R = B - op(A) * X, * where op(A) = A, A**T, or A**H, depending on TRANS. * CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) CALL DGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE, $ WORK( N+1 ), 1 ) * * Compute componentwise relative backward error from formula * * max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) * * where abs(Z) is the componentwise absolute value of the matrix * or vector Z. If the i-th component of the denominator is less * than SAFE2, then SAFE1 is added to the i-th components of the * numerator and denominator before dividing. * DO 30 I = 1, N WORK( I ) = ABS( B( I, J ) ) 30 CONTINUE * * Compute abs(op(A))*abs(X) + abs(B). * IF( NOTRAN ) THEN DO 50 K = 1, N XK = ABS( X( K, J ) ) DO 40 I = 1, N WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK 40 CONTINUE 50 CONTINUE ELSE DO 70 K = 1, N S = ZERO DO 60 I = 1, N S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) 60 CONTINUE WORK( K ) = WORK( K ) + S 70 CONTINUE END IF S = ZERO DO 80 I = 1, N IF( WORK( I ).GT.SAFE2 ) THEN S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) ) ELSE S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / $ ( WORK( I )+SAFE1 ) ) END IF 80 CONTINUE BERR( J ) = S * * Test stopping criterion. Continue iterating if * 1) The residual BERR(J) is larger than machine epsilon, and * 2) BERR(J) decreased by at least a factor of 2 during the * last iteration, and * 3) At most ITMAX iterations tried. * IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. $ COUNT.LE.ITMAX ) THEN * * Update solution and try again. * CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, $ INFO ) CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 ) LSTRES = BERR( J ) COUNT = COUNT + 1 GO TO 20 END IF * * Bound error from formula * * norm(X - XTRUE) / norm(X) .le. FERR = * norm( abs(inv(op(A)))* * ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) * * where * norm(Z) is the magnitude of the largest component of Z * inv(op(A)) is the inverse of op(A) * abs(Z) is the componentwise absolute value of the matrix or * vector Z * NZ is the maximum number of nonzeros in any row of A, plus 1 * EPS is machine epsilon * * The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) * is incremented by SAFE1 if the i-th component of * abs(op(A))*abs(X) + abs(B) is less than SAFE2. * * Use DLACN2 to estimate the infinity-norm of the matrix * inv(op(A)) * diag(W), * where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) * DO 90 I = 1, N IF( WORK( I ).GT.SAFE2 ) THEN WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) ELSE WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1 END IF 90 CONTINUE * KASE = 0 100 CONTINUE CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), $ KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Multiply by diag(W)*inv(op(A)**T). * CALL DGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK( N+1 ), $ N, INFO ) DO 110 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 110 CONTINUE ELSE * * Multiply by inv(op(A))*diag(W). * DO 120 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 120 CONTINUE CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, $ INFO ) END IF GO TO 100 END IF * * Normalize error. * LSTRES = ZERO DO 130 I = 1, N LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) 130 CONTINUE IF( LSTRES.NE.ZERO ) $ FERR( J ) = FERR( J ) / LSTRES * 140 CONTINUE * RETURN * * End of DGERFS * END SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGERQ2 computes an RQ factorization of a real m by n matrix A: * A = R * Q. * * 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 A. * On exit, if m <= n, the upper triangle of the subarray * A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; * if m >= n, the elements on and above the (m-n)-th subdiagonal * contain the m by n upper trapezoidal matrix R; the remaining * elements, 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,M). * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) DOUBLE PRECISION array, dimension (M) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in * A(m-k+i,1:n-k+i-1), and tau in TAU(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * 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( 'DGERQ2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = K, 1, -1 * * Generate elementary reflector H(i) to annihilate * A(m-k+i,1:n-k+i-1) * CALL DLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA, $ TAU( I ) ) * * Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right * AII = A( M-K+I, N-K+I ) A( M-K+I, N-K+I ) = ONE CALL DLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, $ TAU( I ), A, LDA, WORK ) A( M-K+I, N-K+I ) = AII 10 CONTINUE RETURN * * End of DGERQ2 * END SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGERQF computes an RQ factorization of a real M-by-N matrix A: * A = R * Q. * * 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 A. * On exit, * if m <= n, the upper triangle of the subarray * A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R; * if m >= n, the elements on and above the (m-n)-th subdiagonal * contain the M-by-N upper trapezoidal matrix R; * the remaining elements, with the array TAU, represent the * orthogonal matrix Q as a product of min(m,n) elementary * reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * 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 >= max(1,M). * For optimum performance LWORK >= M*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 * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in * A(m-k+i,1:n-k+i-1), and tau in TAU(i). * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT, $ MU, NB, NBMIN, NU, NX * .. * .. External Subroutines .. EXTERNAL DGERQ2, DLARFB, DLARFT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) 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.EQ.0 ) THEN K = MIN( M, N ) IF( K.EQ.0 ) THEN LWKOPT = 1 ELSE NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 ) LWKOPT = M*NB END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGERQF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( K.EQ.0 ) THEN RETURN END IF * NBMIN = 2 NX = 1 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DGERQF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially. * The last kk rows are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * DO 10 I = K - KK + KI + 1, K - KK + 1, -NB IB = MIN( K-I+1, NB ) * * Compute the RQ factorization of the current block * A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1) * CALL DGERQ2( IB, N-K+I+IB-1, A( M-K+I, 1 ), LDA, TAU( I ), $ WORK, IINFO ) IF( M-K+I.GT.1 ) THEN * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB, $ A( M-K+I, 1 ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right * CALL DLARFB( 'Right', 'No transpose', 'Backward', $ 'Rowwise', M-K+I-1, N-K+I+IB-1, IB, $ A( M-K+I, 1 ), LDA, WORK, LDWORK, A, LDA, $ WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE MU = M - K + I + NB - 1 NU = N - K + I + NB - 1 ELSE MU = M NU = N END IF * * Use unblocked code to factor the last or only block * IF( MU.GT.0 .AND. NU.GT.0 ) $ CALL DGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO ) * WORK( 1 ) = IWS RETURN * * End of DGERQF * END SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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 DGETRF( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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 DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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 DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DGETRS solves a system of linear equations * A * X = B or A' * X = B * with a general N-by-N matrix A using the LU factorization computed * by DGETRF. * * Arguments * ========= * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations: * = 'N': A * X = B (No transpose) * = 'T': A'* X = B (Transpose) * = 'C': A'* X = B (Conjugate transpose = Transpose) * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The factors L and U from the factorization A = P*L*U * as computed by DGETRF. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (input) INTEGER array, dimension (N) * The pivot indices from DGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLASWP, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( NOTRAN ) THEN * * Solve A * X = B. * * Apply row interchanges to the right hand sides. * CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) * * Solve L*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, $ ONE, A, LDA, B, LDB ) * * Solve U*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, $ NRHS, ONE, A, LDA, B, LDB ) ELSE * * Solve A' * X = B. * * Solve U'*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, $ ONE, A, LDA, B, LDB ) * * Solve L'*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, $ A, LDA, B, LDB ) * * Apply row interchanges to the solution vectors. * CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) END IF * RETURN * * End of DGETRS * END SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. DOUBLE PRECISION LSCALE( * ), RSCALE( * ), V( LDV, * ) * .. * * Purpose * ======= * * DGGBAK forms the right or left eigenvectors of a real generalized * eigenvalue problem A*x = lambda*B*x, by backward transformation on * the computed eigenvectors of the balanced pair of matrices output by * DGGBAL. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies the type of backward transformation required: * = 'N': do nothing, return immediately; * = 'P': do backward transformation for permutation only; * = 'S': do backward transformation for scaling only; * = 'B': do backward transformations for both permutation and * scaling. * JOB must be the same as the argument JOB supplied to DGGBAL. * * SIDE (input) CHARACTER*1 * = 'R': V contains right eigenvectors; * = 'L': V contains left eigenvectors. * * N (input) INTEGER * The number of rows of the matrix V. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * The integers ILO and IHI determined by DGGBAL. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * LSCALE (input) DOUBLE PRECISION array, dimension (N) * Details of the permutations and/or scaling factors applied * to the left side of A and B, as returned by DGGBAL. * * RSCALE (input) DOUBLE PRECISION array, dimension (N) * Details of the permutations and/or scaling factors applied * to the right side of A and B, as returned by DGGBAL. * * M (input) INTEGER * The number of columns of the matrix V. M >= 0. * * V (input/output) DOUBLE PRECISION array, dimension (LDV,M) * On entry, the matrix of right or left eigenvectors to be * transformed, as returned by DTGEVC. * On exit, V is overwritten by the transformed eigenvectors. * * LDV (input) INTEGER * The leading dimension of the matrix V. LDV >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * See R.C. Ward, Balancing the generalized eigenvalue problem, * SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, K * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN INFO = -4 ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) $ THEN INFO = -5 ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -8 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * * Backward transformation on right eigenvectors * IF( RIGHTV ) THEN DO 10 I = ILO, IHI CALL DSCAL( M, RSCALE( I ), V( I, 1 ), LDV ) 10 CONTINUE END IF * * Backward transformation on left eigenvectors * IF( LEFTV ) THEN DO 20 I = ILO, IHI CALL DSCAL( M, LSCALE( I ), V( I, 1 ), LDV ) 20 CONTINUE END IF END IF * * Backward permutation * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN * * Backward permutation on right eigenvectors * IF( RIGHTV ) THEN IF( ILO.EQ.1 ) $ GO TO 50 * DO 40 I = ILO - 1, 1, -1 K = RSCALE( I ) IF( K.EQ.I ) $ GO TO 40 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE * 50 CONTINUE IF( IHI.EQ.N ) $ GO TO 70 DO 60 I = IHI + 1, N K = RSCALE( I ) IF( K.EQ.I ) $ GO TO 60 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 60 CONTINUE END IF * * Backward permutation on left eigenvectors * 70 CONTINUE IF( LEFTV ) THEN IF( ILO.EQ.1 ) $ GO TO 90 DO 80 I = ILO - 1, 1, -1 K = LSCALE( I ) IF( K.EQ.I ) $ GO TO 80 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 80 CONTINUE * 90 CONTINUE IF( IHI.EQ.N ) $ GO TO 110 DO 100 I = IHI + 1, N K = LSCALE( I ) IF( K.EQ.I ) $ GO TO 100 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 100 CONTINUE END IF END IF * 110 CONTINUE * RETURN * * End of DGGBAK * END SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER JOB INTEGER IHI, ILO, INFO, LDA, LDB, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ), $ RSCALE( * ), WORK( * ) * .. * * Purpose * ======= * * DGGBAL balances a pair of general real matrices (A,B). This * involves, first, permuting A and B by similarity transformations to * isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N * elements on the diagonal; and second, applying a diagonal similarity * transformation to rows and columns ILO to IHI to make the rows * and columns as close in norm as possible. Both steps are optional. * * Balancing may reduce the 1-norm of the matrices, and improve the * accuracy of the computed eigenvalues and/or eigenvectors in the * generalized eigenvalue problem A*x = lambda*B*x. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies the operations to be performed on A and B: * = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 * and RSCALE(I) = 1.0 for i = 1,...,N. * = 'P': permute only; * = 'S': scale only; * = 'B': both permute and scale. * * N (input) INTEGER * The order of the matrices A and B. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the input matrix A. * On exit, A is overwritten by the balanced matrix. * If JOB = 'N', A is not referenced. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input/output) DOUBLE PRECISION array, dimension (LDB,N) * On entry, the input matrix B. * On exit, B is overwritten by the balanced matrix. * If JOB = 'N', B is not referenced. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * ILO (output) INTEGER * IHI (output) INTEGER * ILO and IHI are set to integers such that on exit * A(i,j) = 0 and B(i,j) = 0 if i > j and * j = 1,...,ILO-1 or i = IHI+1,...,N. * If JOB = 'N' or 'S', ILO = 1 and IHI = N. * * LSCALE (output) DOUBLE PRECISION array, dimension (N) * Details of the permutations and scaling factors applied * to the left side of A and B. If P(j) is the index of the * row interchanged with row j, and D(j) * is the scaling factor applied to row j, then * LSCALE(j) = P(j) for J = 1,...,ILO-1 * = D(j) for J = ILO,...,IHI * = P(j) for J = IHI+1,...,N. * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * * RSCALE (output) DOUBLE PRECISION array, dimension (N) * Details of the permutations and scaling factors applied * to the right side of A and B. If P(j) is the index of the * column interchanged with column j, and D(j) * is the scaling factor applied to column j, then * LSCALE(j) = P(j) for J = 1,...,ILO-1 * = D(j) for J = ILO,...,IHI * = P(j) for J = IHI+1,...,N. * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * * WORK (workspace) REAL array, dimension (lwork) * lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and * at least 1 when JOB = 'N' or 'P'. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * See R.C. WARD, Balancing the generalized eigenvalue problem, * SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) DOUBLE PRECISION THREE, SCLFAC PARAMETER ( THREE = 3.0D+0, SCLFAC = 1.0D+1 ) * .. * .. Local Scalars .. INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1, $ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN, $ M, NR, NRP2 DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, $ SFMIN, SUM, T, TA, TB, TC * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGBAL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN ILO = 1 IHI = N RETURN END IF * IF( N.EQ.1 ) THEN ILO = 1 IHI = N LSCALE( 1 ) = ONE RSCALE( 1 ) = ONE RETURN END IF * IF( LSAME( JOB, 'N' ) ) THEN ILO = 1 IHI = N DO 10 I = 1, N LSCALE( I ) = ONE RSCALE( I ) = ONE 10 CONTINUE RETURN END IF * K = 1 L = N IF( LSAME( JOB, 'S' ) ) $ GO TO 190 * GO TO 30 * * Permute the matrices A and B to isolate the eigenvalues. * * Find row with one nonzero in columns 1 through L * 20 CONTINUE L = LM1 IF( L.NE.1 ) $ GO TO 30 * RSCALE( 1 ) = ONE LSCALE( 1 ) = ONE GO TO 190 * 30 CONTINUE LM1 = L - 1 DO 80 I = L, 1, -1 DO 40 J = 1, LM1 JP1 = J + 1 IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) $ GO TO 50 40 CONTINUE J = L GO TO 70 * 50 CONTINUE DO 60 J = JP1, L IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) $ GO TO 80 60 CONTINUE J = JP1 - 1 * 70 CONTINUE M = L IFLOW = 1 GO TO 160 80 CONTINUE GO TO 100 * * Find column with one nonzero in rows K through N * 90 CONTINUE K = K + 1 * 100 CONTINUE DO 150 J = K, L DO 110 I = K, LM1 IP1 = I + 1 IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) $ GO TO 120 110 CONTINUE I = L GO TO 140 120 CONTINUE DO 130 I = IP1, L IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) $ GO TO 150 130 CONTINUE I = IP1 - 1 140 CONTINUE M = K IFLOW = 2 GO TO 160 150 CONTINUE GO TO 190 * * Permute rows M and I * 160 CONTINUE LSCALE( M ) = I IF( I.EQ.M ) $ GO TO 170 CALL DSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) CALL DSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB ) * * Permute columns M and J * 170 CONTINUE RSCALE( M ) = J IF( J.EQ.M ) $ GO TO 180 CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL DSWAP( L, B( 1, J ), 1, B( 1, M ), 1 ) * 180 CONTINUE GO TO ( 20, 90 )IFLOW * 190 CONTINUE ILO = K IHI = L * IF( LSAME( JOB, 'P' ) ) THEN DO 195 I = ILO, IHI LSCALE( I ) = ONE RSCALE( I ) = ONE 195 CONTINUE RETURN END IF * IF( ILO.EQ.IHI ) $ RETURN * * Balance the submatrix in rows ILO to IHI. * NR = IHI - ILO + 1 DO 200 I = ILO, IHI RSCALE( I ) = ZERO LSCALE( I ) = ZERO * WORK( I ) = ZERO WORK( I+N ) = ZERO WORK( I+2*N ) = ZERO WORK( I+3*N ) = ZERO WORK( I+4*N ) = ZERO WORK( I+5*N ) = ZERO 200 CONTINUE * * Compute right side vector in resulting linear equations * BASL = LOG10( SCLFAC ) DO 240 I = ILO, IHI DO 230 J = ILO, IHI TB = B( I, J ) TA = A( I, J ) IF( TA.EQ.ZERO ) $ GO TO 210 TA = LOG10( ABS( TA ) ) / BASL 210 CONTINUE IF( TB.EQ.ZERO ) $ GO TO 220 TB = LOG10( ABS( TB ) ) / BASL 220 CONTINUE WORK( I+4*N ) = WORK( I+4*N ) - TA - TB WORK( J+5*N ) = WORK( J+5*N ) - TA - TB 230 CONTINUE 240 CONTINUE * COEF = ONE / DBLE( 2*NR ) COEF2 = COEF*COEF COEF5 = HALF*COEF2 NRP2 = NR + 2 BETA = ZERO IT = 1 * * Start generalized conjugate gradient iteration * 250 CONTINUE * GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) + $ DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 ) * EW = ZERO EWC = ZERO DO 260 I = ILO, IHI EW = EW + WORK( I+4*N ) EWC = EWC + WORK( I+5*N ) 260 CONTINUE * GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2 IF( GAMMA.EQ.ZERO ) $ GO TO 350 IF( IT.NE.1 ) $ BETA = GAMMA / PGAMMA T = COEF5*( EWC-THREE*EW ) TC = COEF5*( EW-THREE*EWC ) * CALL DSCAL( NR, BETA, WORK( ILO ), 1 ) CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 ) * CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 ) CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 ) * DO 270 I = ILO, IHI WORK( I ) = WORK( I ) + TC WORK( I+N ) = WORK( I+N ) + T 270 CONTINUE * * Apply matrix to vector * DO 300 I = ILO, IHI KOUNT = 0 SUM = ZERO DO 290 J = ILO, IHI IF( A( I, J ).EQ.ZERO ) $ GO TO 280 KOUNT = KOUNT + 1 SUM = SUM + WORK( J ) 280 CONTINUE IF( B( I, J ).EQ.ZERO ) $ GO TO 290 KOUNT = KOUNT + 1 SUM = SUM + WORK( J ) 290 CONTINUE WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM 300 CONTINUE * DO 330 J = ILO, IHI KOUNT = 0 SUM = ZERO DO 320 I = ILO, IHI IF( A( I, J ).EQ.ZERO ) $ GO TO 310 KOUNT = KOUNT + 1 SUM = SUM + WORK( I+N ) 310 CONTINUE IF( B( I, J ).EQ.ZERO ) $ GO TO 320 KOUNT = KOUNT + 1 SUM = SUM + WORK( I+N ) 320 CONTINUE WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM 330 CONTINUE * SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) + $ DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 ) ALPHA = GAMMA / SUM * * Determine correction to current iteration * CMAX = ZERO DO 340 I = ILO, IHI COR = ALPHA*WORK( I+N ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) LSCALE( I ) = LSCALE( I ) + COR COR = ALPHA*WORK( I ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) RSCALE( I ) = RSCALE( I ) + COR 340 CONTINUE IF( CMAX.LT.HALF ) $ GO TO 350 * CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 ) CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 ) * PGAMMA = GAMMA IT = IT + 1 IF( IT.LE.NRP2 ) $ GO TO 250 * * End generalized conjugate gradient iteration * 350 CONTINUE SFMIN = DLAMCH( 'S' ) SFMAX = ONE / SFMIN LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE ) LSFMAX = INT( LOG10( SFMAX ) / BASL ) DO 360 I = ILO, IHI IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) LSCALE( I ) = SCLFAC**IR ICAB = IDAMAX( IHI, A( 1, I ), 1 ) CAB = ABS( A( ICAB, I ) ) ICAB = IDAMAX( IHI, B( 1, I ), 1 ) CAB = MAX( CAB, ABS( B( ICAB, I ) ) ) LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE ) JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) ) JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) RSCALE( I ) = SCLFAC**JC 360 CONTINUE * * Row scaling of matrices A and B * DO 370 I = ILO, IHI CALL DSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA ) CALL DSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB ) 370 CONTINUE * * Column scaling of matrices A and B * DO 380 J = ILO, IHI CALL DSCAL( IHI, RSCALE( J ), A( 1, J ), 1 ) CALL DSCAL( IHI, RSCALE( J ), B( 1, J ), 1 ) 380 CONTINUE * RETURN * * End of DGGBAL * END SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ Z( LDZ, * ) * .. * * Purpose * ======= * * DGGHRD reduces a pair of real matrices (A,B) to generalized upper * Hessenberg form using orthogonal transformations, where A is a * general matrix and B is upper triangular. The form of the * generalized eigenvalue problem is * A*x = lambda*B*x, * and B is typically made upper triangular by computing its QR * factorization and moving the orthogonal matrix Q to the left side * of the equation. * * This subroutine simultaneously reduces A to a Hessenberg matrix H: * Q**T*A*Z = H * and transforms B to another upper triangular matrix T: * Q**T*B*Z = T * in order to reduce the problem to its standard form * H*y = lambda*T*y * where y = Z**T*x. * * The orthogonal matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be * postmultiplied into input matrices Q1 and Z1, so that * * Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T * * Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T * * If Q1 is the orthogonal matrix from the QR factorization of B in the * original equation A*x = lambda*B*x, then DGGHRD reduces the original * problem to generalized Hessenberg form. * * Arguments * ========= * * COMPQ (input) CHARACTER*1 * = 'N': do not compute Q; * = 'I': Q is initialized to the unit matrix, and the * orthogonal matrix Q is returned; * = 'V': Q must contain an orthogonal matrix Q1 on entry, * and the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 * = 'N': do not compute Z; * = 'I': Z is initialized to the unit matrix, and the * orthogonal matrix Z is returned; * = 'V': Z must contain an orthogonal matrix Z1 on entry, * and the product Z1*Z is returned. * * N (input) INTEGER * The order of the matrices A and B. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * ILO and IHI mark the rows and columns of A which are to be * reduced. It is assumed that A is already upper triangular * in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are * normally set by a previous call to SGGBAL; otherwise they * should be set to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) * On entry, the N-by-N general matrix to be reduced. * On exit, the upper triangle and the first subdiagonal of A * are overwritten with the upper Hessenberg matrix H, and the * rest is set to zero. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input/output) DOUBLE PRECISION array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. * On exit, the upper triangular matrix T = Q**T B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) * On entry, if COMPQ = 'V', the orthogonal matrix Q1, * typically from the QR factorization of B. * On exit, if COMPQ='I', the orthogonal matrix Q, and if * COMPQ = 'V', the product Q1*Q. * Not referenced if COMPQ='N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) * On entry, if COMPZ = 'V', the orthogonal matrix Z1. * On exit, if COMPZ='I', the orthogonal matrix Z, and if * COMPZ = 'V', the product Z1*Z. * Not referenced if COMPZ='N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. * LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * This routine reduces A to Hessenberg and B to triangular form by * an unblocked reduction, as described in _Matrix_Computations_, * by Golub and Van Loan (Johns Hopkins Press.) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL ILQ, ILZ INTEGER ICOMPQ, ICOMPZ, JCOL, JROW DOUBLE PRECISION C, S, TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARTG, DLASET, DROT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode COMPQ * IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF * * Decode COMPZ * IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF * * Test the input parameters. * INFO = 0 IF( ICOMPQ.LE.0 ) THEN INFO = -1 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN INFO = -11 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGHRD', -INFO ) RETURN END IF * * Initialize Q and Z if desired. * IF( ICOMPQ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Zero out lower triangle of B * DO 20 JCOL = 1, N - 1 DO 10 JROW = JCOL + 1, N B( JROW, JCOL ) = ZERO 10 CONTINUE 20 CONTINUE * * Reduce A and B * DO 40 JCOL = ILO, IHI - 2 * DO 30 JROW = IHI, JCOL + 2, -1 * * Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) * TEMP = A( JROW-1, JCOL ) CALL DLARTG( TEMP, A( JROW, JCOL ), C, S, $ A( JROW-1, JCOL ) ) A( JROW, JCOL ) = ZERO CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, $ A( JROW, JCOL+1 ), LDA, C, S ) CALL DROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB, $ B( JROW, JROW-1 ), LDB, C, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S ) * * Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) * TEMP = B( JROW, JROW ) CALL DLARTG( TEMP, B( JROW, JROW-1 ), C, S, $ B( JROW, JROW ) ) B( JROW, JROW-1 ) = ZERO CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S ) CALL DROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C, $ S ) IF( ILZ ) $ CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S ) 30 CONTINUE 40 CONTINUE * RETURN * * End of DGGHRD * END SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), $ WORK( * ) * .. * * Purpose * ======= * * DGGQRF computes a generalized QR factorization of an N-by-M matrix A * and an N-by-P matrix B: * * A = Q*R, B = Q*T*Z, * * where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal * matrix, and R and T assume one of the forms: * * if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N, * ( 0 ) N-M N M-N * M * * where R11 is upper triangular, and * * if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P, * P-N N ( T21 ) P * P * * where T12 or T21 is upper triangular. * * In particular, if B is square and nonsingular, the GQR factorization * of A and B implicitly gives the QR factorization of inv(B)*A: * * inv(B)*A = Z'*(inv(T)*R) * * where inv(B) denotes the inverse of the matrix B, and Z' denotes the * transpose of the matrix Z. * * Arguments * ========= * * N (input) INTEGER * The number of rows of the matrices A and B. N >= 0. * * M (input) INTEGER * The number of columns of the matrix A. M >= 0. * * P (input) INTEGER * The number of columns of the matrix B. P >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,M) * On entry, the N-by-M matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(N,M)-by-M upper trapezoidal matrix R (R is * upper triangular if N >= M); the elements below the diagonal, * with the array TAUA, represent the orthogonal matrix Q as a * product of min(N,M) elementary reflectors (see Further * Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * TAUA (output) DOUBLE PRECISION array, dimension (min(N,M)) * The scalar factors of the elementary reflectors which * represent the orthogonal matrix Q (see Further Details). * * B (input/output) DOUBLE PRECISION array, dimension (LDB,P) * On entry, the N-by-P matrix B. * On exit, if N <= P, the upper triangle of the subarray * B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; * if N > P, the elements on and above the (N-P)-th subdiagonal * contain the N-by-P upper trapezoidal matrix T; the remaining * elements, with the array TAUB, represent the orthogonal * matrix Z as a product of elementary reflectors (see Further * Details). * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * TAUB (output) DOUBLE PRECISION array, dimension (min(N,P)) * The scalar factors of the elementary reflectors which * represent the orthogonal matrix Z (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 >= max(1,N,M,P). * For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), * where NB1 is the optimal blocksize for the QR factorization * of an N-by-M matrix, NB2 is the optimal blocksize for the * RQ factorization of an N-by-P matrix, and NB3 is the optimal * blocksize for a call of DORMQR. * * 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 * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(n,m). * * Each H(i) has the form * * H(i) = I - taua * v * v' * * where taua is a real scalar, and v is a real vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), * and taua in TAUA(i). * To form Q explicitly, use LAPACK subroutine DORGQR. * To use Q to update another matrix, use LAPACK subroutine DORMQR. * * The matrix Z is represented as a product of elementary reflectors * * Z = H(1) H(2) . . . H(k), where k = min(n,p). * * Each H(i) has the form * * H(i) = I - taub * v * v' * * where taub is a real scalar, and v is a real vector with * v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in * B(n-k+i,1:p-k+i-1), and taub in TAUB(i). * To form Z explicitly, use LAPACK subroutine DORGRQ. * To use Z to update another matrix, use LAPACK subroutine DORMRQ. * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3 * .. * .. External Subroutines .. EXTERNAL DGEQRF, DGERQF, DORMQR, XERBLA * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 ) NB2 = ILAENV( 1, 'DGERQF', ' ', N, P, -1, -1 ) NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 ) NB = MAX( NB1, NB2, NB3 ) LWKOPT = MAX( N, M, P )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( P.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LWORK.LT.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGQRF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * QR factorization of N-by-M matrix A: A = Q*R * CALL DGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO ) LOPT = WORK( 1 ) * * Update B := Q'*B. * CALL DORMQR( 'Left', 'Transpose', N, P, MIN( N, M ), A, LDA, TAUA, $ B, LDB, WORK, LWORK, INFO ) LOPT = MAX( LOPT, INT( WORK( 1 ) ) ) * * RQ factorization of N-by-P matrix B: B = T*Z. * CALL DGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO ) WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) ) * RETURN * * End of DGGQRF * END SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), $ WORK( * ) * .. * * Purpose * ======= * * DGGRQF computes a generalized RQ factorization of an M-by-N matrix A * and a P-by-N matrix B: * * A = R*Q, B = Z*T*Q, * * where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal * matrix, and R and T assume one of the forms: * * if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N, * N-M M ( R21 ) N * N * * where R12 or R21 is upper triangular, and * * if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P, * ( 0 ) P-N P N-P * N * * where T11 is upper triangular. * * In particular, if B is square and nonsingular, the GRQ factorization * of A and B implicitly gives the RQ factorization of A*inv(B): * * A*inv(B) = (R*inv(T))*Z' * * where inv(B) denotes the inverse of the matrix B, and Z' denotes the * transpose of the matrix Z. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * P (input) INTEGER * The number of rows of the matrix B. P >= 0. * * N (input) INTEGER * The number of columns of the matrices A and B. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, if M <= N, the upper triangle of the subarray * A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R; * if M > N, the elements on and above the (M-N)-th subdiagonal * contain the M-by-N upper trapezoidal matrix R; the remaining * elements, with the array TAUA, 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,M). * * TAUA (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the orthogonal matrix Q (see Further Details). * * B (input/output) DOUBLE PRECISION array, dimension (LDB,N) * On entry, the P-by-N matrix B. * On exit, the elements on and above the diagonal of the array * contain the min(P,N)-by-N upper trapezoidal matrix T (T is * upper triangular if P >= N); the elements below the diagonal, * with the array TAUB, represent the orthogonal matrix Z as a * product of elementary reflectors (see Further Details). * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,P). * * TAUB (output) DOUBLE PRECISION array, dimension (min(P,N)) * The scalar factors of the elementary reflectors which * represent the orthogonal matrix Z (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 >= max(1,N,M,P). * For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), * where NB1 is the optimal blocksize for the RQ factorization * of an M-by-N matrix, NB2 is the optimal blocksize for the * QR factorization of a P-by-N matrix, and NB3 is the optimal * blocksize for a call of DORMRQ. * * 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 INF0= -i, the i-th argument had an illegal value. * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - taua * v * v' * * where taua is a real scalar, and v is a real vector with * v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in * A(m-k+i,1:n-k+i-1), and taua in TAUA(i). * To form Q explicitly, use LAPACK subroutine DORGRQ. * To use Q to update another matrix, use LAPACK subroutine DORMRQ. * * The matrix Z is represented as a product of elementary reflectors * * Z = H(1) H(2) . . . H(k), where k = min(p,n). * * Each H(i) has the form * * H(i) = I - taub * v * v' * * where taub is a real scalar, and v is a real vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i), * and taub in TAUB(i). * To form Z explicitly, use LAPACK subroutine DORGQR. * To use Z to update another matrix, use LAPACK subroutine DORMQR. * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3 * .. * .. External Subroutines .. EXTERNAL DGEQRF, DGERQF, DORMRQ, XERBLA * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NB1 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 ) NB2 = ILAENV( 1, 'DGEQRF', ' ', P, N, -1, -1 ) NB3 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 ) NB = MAX( NB1, NB2, NB3 ) LWKOPT = MAX( N, M, P )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( P.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, P ) ) THEN INFO = -8 ELSE IF( LWORK.LT.MAX( 1, M, P, N ) .AND. .NOT.LQUERY ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGRQF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * RQ factorization of M-by-N matrix A: A = R*Q * CALL DGERQF( M, N, A, LDA, TAUA, WORK, LWORK, INFO ) LOPT = WORK( 1 ) * * Update B := B*Q' * CALL DORMRQ( 'Right', 'Transpose', P, N, MIN( M, N ), $ A( MAX( 1, M-N+1 ), 1 ), LDA, TAUA, B, LDB, WORK, $ LWORK, INFO ) LOPT = MAX( LOPT, INT( WORK( 1 ) ) ) * * QR factorization of P-by-N matrix B: B = Z*T * CALL DGEQRF( P, N, B, LDB, TAUB, WORK, LWORK, INFO ) WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) ) * RETURN * * End of DGGRQF * END SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P DOUBLE PRECISION TOLA, TOLB * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) * .. * * Purpose * ======= * * DGGSVP computes orthogonal matrices U, V and Q such that * * N-K-L K L * U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; * L ( 0 0 A23 ) * M-K-L ( 0 0 0 ) * * N-K-L K L * = K ( 0 A12 A13 ) if M-K-L < 0; * M-K ( 0 0 A23 ) * * N-K-L K L * V'*B*Q = L ( 0 0 B13 ) * P-L ( 0 0 0 ) * * where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular * upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, * otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective * numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the * transpose of Z. * * This decomposition is the preprocessing step for computing the * Generalized Singular Value Decomposition (GSVD), see subroutine * DGGSVD. * * Arguments * ========= * * JOBU (input) CHARACTER*1 * = 'U': Orthogonal matrix U is computed; * = 'N': U is not computed. * * JOBV (input) CHARACTER*1 * = 'V': Orthogonal matrix V is computed; * = 'N': V is not computed. * * JOBQ (input) CHARACTER*1 * = 'Q': Orthogonal matrix Q is computed; * = 'N': Q is not computed. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * P (input) INTEGER * The number of rows of the matrix B. P >= 0. * * N (input) INTEGER * The number of columns of the matrices A and B. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, A contains the triangular (or trapezoidal) matrix * described in the Purpose section. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (input/output) DOUBLE PRECISION array, dimension (LDB,N) * On entry, the P-by-N matrix B. * On exit, B contains the triangular matrix described in * the Purpose section. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,P). * * TOLA (input) DOUBLE PRECISION * TOLB (input) DOUBLE PRECISION * TOLA and TOLB are the thresholds to determine the effective * numerical rank of matrix B and a subblock of A. Generally, * they are set to * TOLA = MAX(M,N)*norm(A)*MAZHEPS, * TOLB = MAX(P,N)*norm(B)*MAZHEPS. * The size of TOLA and TOLB may affect the size of backward * errors of the decomposition. * * K (output) INTEGER * L (output) INTEGER * On exit, K and L specify the dimension of the subblocks * described in Purpose. * K + L = effective numerical rank of (A',B')'. * * U (output) DOUBLE PRECISION array, dimension (LDU,M) * If JOBU = 'U', U contains the orthogonal matrix U. * If JOBU = 'N', U is not referenced. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,M) if * JOBU = 'U'; LDU >= 1 otherwise. * * V (output) DOUBLE PRECISION array, dimension (LDV,M) * If JOBV = 'V', V contains the orthogonal matrix V. * If JOBV = 'N', V is not referenced. * * LDV (input) INTEGER * The leading dimension of the array V. LDV >= max(1,P) if * JOBV = 'V'; LDV >= 1 otherwise. * * Q (output) DOUBLE PRECISION array, dimension (LDQ,N) * If JOBQ = 'Q', Q contains the orthogonal matrix Q. * If JOBQ = 'N', Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= max(1,N) if * JOBQ = 'Q'; LDQ >= 1 otherwise. * * IWORK (workspace) INTEGER array, dimension (N) * * TAU (workspace) DOUBLE PRECISION array, dimension (N) * * WORK (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P)) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * * Further Details * =============== * * The subroutine uses LAPACK subroutine DGEQPF for the QR factorization * with column pivoting to detect the effective numerical rank of the * a matrix. It may be replaced by a better rank determination strategy. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL FORWRD, WANTQ, WANTU, WANTV INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEQPF, DGEQR2, DGERQ2, DLACPY, DLAPMT, DLASET, $ DORG2R, DORM2R, DORMR2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * WANTU = LSAME( JOBU, 'U' ) WANTV = LSAME( JOBV, 'V' ) WANTQ = LSAME( JOBQ, 'Q' ) FORWRD = .TRUE. * INFO = 0 IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( P.LT.0 ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDB.LT.MAX( 1, P ) ) THEN INFO = -10 ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN INFO = -16 ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN INFO = -18 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -20 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGSVP', -INFO ) RETURN END IF * * QR with column pivoting of B: B*P = V*( S11 S12 ) * ( 0 0 ) * DO 10 I = 1, N IWORK( I ) = 0 10 CONTINUE CALL DGEQPF( P, N, B, LDB, IWORK, TAU, WORK, INFO ) * * Update A := A*P * CALL DLAPMT( FORWRD, M, N, A, LDA, IWORK ) * * Determine the effective rank of matrix B. * L = 0 DO 20 I = 1, MIN( P, N ) IF( ABS( B( I, I ) ).GT.TOLB ) $ L = L + 1 20 CONTINUE * IF( WANTV ) THEN * * Copy the details of V, and form V. * CALL DLASET( 'Full', P, P, ZERO, ZERO, V, LDV ) IF( P.GT.1 ) $ CALL DLACPY( 'Lower', P-1, N, B( 2, 1 ), LDB, V( 2, 1 ), $ LDV ) CALL DORG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO ) END IF * * Clean up B * DO 40 J = 1, L - 1 DO 30 I = J + 1, L B( I, J ) = ZERO 30 CONTINUE 40 CONTINUE IF( P.GT.L ) $ CALL DLASET( 'Full', P-L, N, ZERO, ZERO, B( L+1, 1 ), LDB ) * IF( WANTQ ) THEN * * Set Q = I and Update Q := Q*P * CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) CALL DLAPMT( FORWRD, N, N, Q, LDQ, IWORK ) END IF * IF( P.GE.L .AND. N.NE.L ) THEN * * RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z * CALL DGERQ2( L, N, B, LDB, TAU, WORK, INFO ) * * Update A := A*Z' * CALL DORMR2( 'Right', 'Transpose', M, N, L, B, LDB, TAU, A, $ LDA, WORK, INFO ) * IF( WANTQ ) THEN * * Update Q := Q*Z' * CALL DORMR2( 'Right', 'Transpose', N, N, L, B, LDB, TAU, Q, $ LDQ, WORK, INFO ) END IF * * Clean up B * CALL DLASET( 'Full', L, N-L, ZERO, ZERO, B, LDB ) DO 60 J = N - L + 1, N DO 50 I = J - N + L + 1, L B( I, J ) = ZERO 50 CONTINUE 60 CONTINUE * END IF * * Let N-L L * A = ( A11 A12 ) M, * * then the following does the complete QR decomposition of A11: * * A11 = U*( 0 T12 )*P1' * ( 0 0 ) * DO 70 I = 1, N - L IWORK( I ) = 0 70 CONTINUE CALL DGEQPF( M, N-L, A, LDA, IWORK, TAU, WORK, INFO ) * * Determine the effective rank of A11 * K = 0 DO 80 I = 1, MIN( M, N-L ) IF( ABS( A( I, I ) ).GT.TOLA ) $ K = K + 1 80 CONTINUE * * Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N ) * CALL DORM2R( 'Left', 'Transpose', M, L, MIN( M, N-L ), A, LDA, $ TAU, A( 1, N-L+1 ), LDA, WORK, INFO ) * IF( WANTU ) THEN * * Copy the details of U, and form U * CALL DLASET( 'Full', M, M, ZERO, ZERO, U, LDU ) IF( M.GT.1 ) $ CALL DLACPY( 'Lower', M-1, N-L, A( 2, 1 ), LDA, U( 2, 1 ), $ LDU ) CALL DORG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO ) END IF * IF( WANTQ ) THEN * * Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 * CALL DLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK ) END IF * * Clean up A: set the strictly lower triangular part of * A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. * DO 100 J = 1, K - 1 DO 90 I = J + 1, K A( I, J ) = ZERO 90 CONTINUE 100 CONTINUE IF( M.GT.K ) $ CALL DLASET( 'Full', M-K, N-L, ZERO, ZERO, A( K+1, 1 ), LDA ) * IF( N-L.GT.K ) THEN * * RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 * CALL DGERQ2( K, N-L, A, LDA, TAU, WORK, INFO ) * IF( WANTQ ) THEN * * Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' * CALL DORMR2( 'Right', 'Transpose', N, N-L, K, A, LDA, TAU, $ Q, LDQ, WORK, INFO ) END IF * * Clean up A * CALL DLASET( 'Full', K, N-L-K, ZERO, ZERO, A, LDA ) DO 120 J = N - L - K + 1, N - L DO 110 I = J - N + L + K + 1, K A( I, J ) = ZERO 110 CONTINUE 120 CONTINUE * END IF * IF( M.GT.K ) THEN * * QR factorization of A( K+1:M,N-L+1:N ) * CALL DGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO ) * IF( WANTU ) THEN * * Update U(:,K+1:M) := U(:,K+1:M)*U1 * CALL DORM2R( 'Right', 'No transpose', M, M-K, MIN( M-K, L ), $ A( K+1, N-L+1 ), LDA, TAU, U( 1, K+1 ), LDU, $ WORK, INFO ) END IF * * Clean up * DO 140 J = N - L + 1, N DO 130 I = J - N + K + L + 1, M A( I, J ) = ZERO 130 CONTINUE 140 CONTINUE * END IF * RETURN * * End of DGGSVP * END SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER NORM INTEGER INFO, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ), WORK( * ) * .. * * Purpose * ======= * * DGTCON estimates the reciprocal of the condition number of a real * tridiagonal matrix A using the LU factorization as computed by * DGTTRF. * * An estimate is obtained for norm(inv(A)), and the reciprocal of the * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies whether the 1-norm condition number or the * infinity-norm condition number is required: * = '1' or 'O': 1-norm; * = 'I': Infinity-norm. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * DL (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) multipliers that define the matrix L from the * LU factorization of A as computed by DGTTRF. * * D (input) DOUBLE PRECISION array, dimension (N) * The n diagonal elements of the upper triangular matrix U from * the LU factorization of A. * * DU (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) elements of the first superdiagonal of U. * * DU2 (input) DOUBLE PRECISION array, dimension (N-2) * The (n-2) elements of the second superdiagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was * interchanged with row IPIV(i). IPIV(i) will always be either * i or i+1; IPIV(i) = i indicates a row interchange was not * required. * * ANORM (input) DOUBLE PRECISION * If NORM = '1' or 'O', the 1-norm of the original matrix A. * If NORM = 'I', the infinity-norm of the original matrix A. * * RCOND (output) DOUBLE PRECISION * The reciprocal of the condition number of the matrix A, * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an * estimate of the 1-norm of inv(A) computed in this routine. * * WORK (workspace) DOUBLE PRECISION array, dimension (2*N) * * IWORK (workspace) INTEGER array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL ONENRM INTEGER I, KASE, KASE1 DOUBLE PRECISION AINVNM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGTTRS, DLACN2, XERBLA * .. * .. Executable Statements .. * * Test the input arguments. * INFO = 0 ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ANORM.LT.ZERO ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGTCON', -INFO ) RETURN END IF * * Quick return if possible * RCOND = ZERO IF( N.EQ.0 ) THEN RCOND = ONE RETURN ELSE IF( ANORM.EQ.ZERO ) THEN RETURN END IF * * Check that D(1:N) is non-zero. * DO 10 I = 1, N IF( D( I ).EQ.ZERO ) $ RETURN 10 CONTINUE * AINVNM = ZERO IF( ONENRM ) THEN KASE1 = 1 ELSE KASE1 = 2 END IF KASE = 0 20 CONTINUE CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * * Multiply by inv(U)*inv(L). * CALL DGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV, $ WORK, N, INFO ) ELSE * * Multiply by inv(L')*inv(U'). * CALL DGTTRS( 'Transpose', N, 1, DL, D, DU, DU2, IPIV, WORK, $ N, INFO ) END IF GO TO 20 END IF * * Compute the estimate of the reciprocal condition number. * IF( AINVNM.NE.ZERO ) $ RCOND = ( ONE / AINVNM ) / ANORM * RETURN * * End of DGTCON * END SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDB, LDX, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), $ FERR( * ), WORK( * ), X( LDX, * ) * .. * * Purpose * ======= * * DGTRFS improves the computed solution to a system of linear * equations when the coefficient matrix is tridiagonal, and provides * error bounds and backward error estimates for the solution. * * Arguments * ========= * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations: * = 'N': A * X = B (No transpose) * = 'T': A**T * X = B (Transpose) * = 'C': A**H * X = B (Conjugate transpose = Transpose) * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * DL (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) subdiagonal elements of A. * * D (input) DOUBLE PRECISION array, dimension (N) * The diagonal elements of A. * * DU (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) superdiagonal elements of A. * * DLF (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) multipliers that define the matrix L from the * LU factorization of A as computed by DGTTRF. * * DF (input) DOUBLE PRECISION array, dimension (N) * The n diagonal elements of the upper triangular matrix U from * the LU factorization of A. * * DUF (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) elements of the first superdiagonal of U. * * DU2 (input) DOUBLE PRECISION array, dimension (N-2) * The (n-2) elements of the second superdiagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was * interchanged with row IPIV(i). IPIV(i) will always be either * i or i+1; IPIV(i) = i indicates a row interchange was not * required. * * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) * The right hand side matrix B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) * On entry, the solution matrix X, as computed by DGTTRS. * On exit, the improved solution matrix X. * * LDX (input) INTEGER * The leading dimension of the array X. LDX >= max(1,N). * * FERR (output) DOUBLE PRECISION array, dimension (NRHS) * The estimated forward error bound for each solution vector * X(j) (the j-th column of the solution matrix X). * If XTRUE is the true solution corresponding to X(j), FERR(j) * is an estimated upper bound for the magnitude of the largest * element in (X(j) - XTRUE) divided by the magnitude of the * largest element in X(j). The estimate is as reliable as * the estimate for RCOND, and is almost always a slight * overestimate of the true error. * * BERR (output) DOUBLE PRECISION array, dimension (NRHS) * The componentwise relative backward error of each solution * vector X(j) (i.e., the smallest relative change in * any element of A or B that makes X(j) an exact solution). * * WORK (workspace) DOUBLE PRECISION array, dimension (3*N) * * IWORK (workspace) INTEGER array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Internal Parameters * =================== * * ITMAX is the maximum number of steps of iterative refinement. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D+0 ) DOUBLE PRECISION THREE PARAMETER ( THREE = 3.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN CHARACTER TRANSN, TRANST INTEGER COUNT, I, J, KASE, NZ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGTTRS, DLACN2, DLAGTM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -15 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGTRFS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN DO 10 J = 1, NRHS FERR( J ) = ZERO BERR( J ) = ZERO 10 CONTINUE RETURN END IF * IF( NOTRAN ) THEN TRANSN = 'N' TRANST = 'T' ELSE TRANSN = 'T' TRANST = 'N' END IF * * NZ = maximum number of nonzero elements in each row of A, plus 1 * NZ = 4 EPS = DLAMCH( 'Epsilon' ) SAFMIN = DLAMCH( 'Safe minimum' ) SAFE1 = NZ*SAFMIN SAFE2 = SAFE1 / EPS * * Do for each right hand side * DO 110 J = 1, NRHS * COUNT = 1 LSTRES = THREE 20 CONTINUE * * Loop until stopping criterion is satisfied. * * Compute residual R = B - op(A) * X, * where op(A) = A, A**T, or A**H, depending on TRANS. * CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) CALL DLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE, $ WORK( N+1 ), N ) * * Compute abs(op(A))*abs(x) + abs(b) for use in the backward * error bound. * IF( NOTRAN ) THEN IF( N.EQ.1 ) THEN WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) ELSE WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) + $ ABS( DU( 1 )*X( 2, J ) ) DO 30 I = 2, N - 1 WORK( I ) = ABS( B( I, J ) ) + $ ABS( DL( I-1 )*X( I-1, J ) ) + $ ABS( D( I )*X( I, J ) ) + $ ABS( DU( I )*X( I+1, J ) ) 30 CONTINUE WORK( N ) = ABS( B( N, J ) ) + $ ABS( DL( N-1 )*X( N-1, J ) ) + $ ABS( D( N )*X( N, J ) ) END IF ELSE IF( N.EQ.1 ) THEN WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) ELSE WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) + $ ABS( DL( 1 )*X( 2, J ) ) DO 40 I = 2, N - 1 WORK( I ) = ABS( B( I, J ) ) + $ ABS( DU( I-1 )*X( I-1, J ) ) + $ ABS( D( I )*X( I, J ) ) + $ ABS( DL( I )*X( I+1, J ) ) 40 CONTINUE WORK( N ) = ABS( B( N, J ) ) + $ ABS( DU( N-1 )*X( N-1, J ) ) + $ ABS( D( N )*X( N, J ) ) END IF END IF * * Compute componentwise relative backward error from formula * * max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) * * where abs(Z) is the componentwise absolute value of the matrix * or vector Z. If the i-th component of the denominator is less * than SAFE2, then SAFE1 is added to the i-th components of the * numerator and denominator before dividing. * S = ZERO DO 50 I = 1, N IF( WORK( I ).GT.SAFE2 ) THEN S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) ) ELSE S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / $ ( WORK( I )+SAFE1 ) ) END IF 50 CONTINUE BERR( J ) = S * * Test stopping criterion. Continue iterating if * 1) The residual BERR(J) is larger than machine epsilon, and * 2) BERR(J) decreased by at least a factor of 2 during the * last iteration, and * 3) At most ITMAX iterations tried. * IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. $ COUNT.LE.ITMAX ) THEN * * Update solution and try again. * CALL DGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV, $ WORK( N+1 ), N, INFO ) CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 ) LSTRES = BERR( J ) COUNT = COUNT + 1 GO TO 20 END IF * * Bound error from formula * * norm(X - XTRUE) / norm(X) .le. FERR = * norm( abs(inv(op(A)))* * ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) * * where * norm(Z) is the magnitude of the largest component of Z * inv(op(A)) is the inverse of op(A) * abs(Z) is the componentwise absolute value of the matrix or * vector Z * NZ is the maximum number of nonzeros in any row of A, plus 1 * EPS is machine epsilon * * The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) * is incremented by SAFE1 if the i-th component of * abs(op(A))*abs(X) + abs(B) is less than SAFE2. * * Use DLACN2 to estimate the infinity-norm of the matrix * inv(op(A)) * diag(W), * where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) * DO 60 I = 1, N IF( WORK( I ).GT.SAFE2 ) THEN WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) ELSE WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1 END IF 60 CONTINUE * KASE = 0 70 CONTINUE CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), $ KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Multiply by diag(W)*inv(op(A)**T). * CALL DGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV, $ WORK( N+1 ), N, INFO ) DO 80 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 80 CONTINUE ELSE * * Multiply by inv(op(A))*diag(W). * DO 90 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 90 CONTINUE CALL DGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV, $ WORK( N+1 ), N, INFO ) END IF GO TO 70 END IF * * Normalize error. * LSTRES = ZERO DO 100 I = 1, N LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) 100 CONTINUE IF( LSTRES.NE.ZERO ) $ FERR( J ) = FERR( J ) / LSTRES * 110 CONTINUE * RETURN * * End of DGTRFS * END SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ) * .. * * Purpose * ======= * * DGTSV solves the equation * * A*X = B, * * where A is an n by n tridiagonal matrix, by Gaussian elimination with * partial pivoting. * * Note that the equation A'*X = B may be solved by interchanging the * order of the arguments DU and DL. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * DL (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, DL must contain the (n-1) sub-diagonal elements of * A. * * On exit, DL is overwritten by the (n-2) elements of the * second super-diagonal of the upper triangular matrix U from * the LU factorization of A, in DL(1), ..., DL(n-2). * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, D must contain the diagonal elements of A. * * On exit, D is overwritten by the n diagonal elements of U. * * DU (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, DU must contain the (n-1) super-diagonal elements * of A. * * On exit, DU is overwritten by the (n-1) elements of the first * super-diagonal of U. * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the N by NRHS matrix of right hand side matrix B. * On exit, if INFO = 0, the N by NRHS solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, U(i,i) is exactly zero, and the solution * has not been computed. The factorization has not been * completed unless i = N. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION FACT, TEMP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NRHS.LT.0 ) THEN INFO = -2 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGTSV ', -INFO ) RETURN END IF * IF( N.EQ.0 ) $ RETURN * IF( NRHS.EQ.1 ) THEN DO 10 I = 1, N - 2 IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN * * No row interchange required * IF( D( I ).NE.ZERO ) THEN FACT = DL( I ) / D( I ) D( I+1 ) = D( I+1 ) - FACT*DU( I ) B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 ) ELSE INFO = I RETURN END IF DL( I ) = ZERO ELSE * * Interchange rows I and I+1 * FACT = D( I ) / DL( I ) D( I ) = DL( I ) TEMP = D( I+1 ) D( I+1 ) = DU( I ) - FACT*TEMP DL( I ) = DU( I+1 ) DU( I+1 ) = -FACT*DL( I ) DU( I ) = TEMP TEMP = B( I, 1 ) B( I, 1 ) = B( I+1, 1 ) B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 ) END IF 10 CONTINUE IF( N.GT.1 ) THEN I = N - 1 IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN IF( D( I ).NE.ZERO ) THEN FACT = DL( I ) / D( I ) D( I+1 ) = D( I+1 ) - FACT*DU( I ) B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 ) ELSE INFO = I RETURN END IF ELSE FACT = D( I ) / DL( I ) D( I ) = DL( I ) TEMP = D( I+1 ) D( I+1 ) = DU( I ) - FACT*TEMP DU( I ) = TEMP TEMP = B( I, 1 ) B( I, 1 ) = B( I+1, 1 ) B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 ) END IF END IF IF( D( N ).EQ.ZERO ) THEN INFO = N RETURN END IF ELSE DO 40 I = 1, N - 2 IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN * * No row interchange required * IF( D( I ).NE.ZERO ) THEN FACT = DL( I ) / D( I ) D( I+1 ) = D( I+1 ) - FACT*DU( I ) DO 20 J = 1, NRHS B( I+1, J ) = B( I+1, J ) - FACT*B( I, J ) 20 CONTINUE ELSE INFO = I RETURN END IF DL( I ) = ZERO ELSE * * Interchange rows I and I+1 * FACT = D( I ) / DL( I ) D( I ) = DL( I ) TEMP = D( I+1 ) D( I+1 ) = DU( I ) - FACT*TEMP DL( I ) = DU( I+1 ) DU( I+1 ) = -FACT*DL( I ) DU( I ) = TEMP DO 30 J = 1, NRHS TEMP = B( I, J ) B( I, J ) = B( I+1, J ) B( I+1, J ) = TEMP - FACT*B( I+1, J ) 30 CONTINUE END IF 40 CONTINUE IF( N.GT.1 ) THEN I = N - 1 IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN IF( D( I ).NE.ZERO ) THEN FACT = DL( I ) / D( I ) D( I+1 ) = D( I+1 ) - FACT*DU( I ) DO 50 J = 1, NRHS B( I+1, J ) = B( I+1, J ) - FACT*B( I, J ) 50 CONTINUE ELSE INFO = I RETURN END IF ELSE FACT = D( I ) / DL( I ) D( I ) = DL( I ) TEMP = D( I+1 ) D( I+1 ) = DU( I ) - FACT*TEMP DU( I ) = TEMP DO 60 J = 1, NRHS TEMP = B( I, J ) B( I, J ) = B( I+1, J ) B( I+1, J ) = TEMP - FACT*B( I+1, J ) 60 CONTINUE END IF END IF IF( D( N ).EQ.ZERO ) THEN INFO = N RETURN END IF END IF * * Back solve with the matrix U from the factorization. * IF( NRHS.LE.2 ) THEN J = 1 70 CONTINUE B( N, J ) = B( N, J ) / D( N ) IF( N.GT.1 ) $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 ) DO 80 I = N - 2, 1, -1 B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )* $ B( I+2, J ) ) / D( I ) 80 CONTINUE IF( J.LT.NRHS ) THEN J = J + 1 GO TO 70 END IF ELSE DO 100 J = 1, NRHS B( N, J ) = B( N, J ) / D( N ) IF( N.GT.1 ) $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / $ D( N-1 ) DO 90 I = N - 2, 1, -1 B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )* $ B( I+2, J ) ) / D( I ) 90 CONTINUE 100 CONTINUE END IF * RETURN * * End of DGTSV * END SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER FACT, TRANS INTEGER INFO, LDB, LDX, N, NRHS DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), $ FERR( * ), WORK( * ), X( LDX, * ) * .. * * Purpose * ======= * * DGTSVX uses the LU factorization to compute the solution to a real * system of linear equations A * X = B or A**T * X = B, * where A is a tridiagonal matrix of order N and X and B are N-by-NRHS * matrices. * * Error bounds on the solution and a condition estimate are also * provided. * * Description * =========== * * The following steps are performed: * * 1. If FACT = 'N', the LU decomposition is used to factor the matrix A * as A = L * U, where L is a product of permutation and unit lower * bidiagonal matrices and U is upper triangular with nonzeros in * only the main diagonal and first two superdiagonals. * * 2. If some U(i,i)=0, so that U is exactly singular, then the routine * returns with INFO = i. Otherwise, the factored form of A is used * to estimate the condition number of the matrix A. If the * reciprocal of the condition number is less than machine precision, * INFO = N+1 is returned as a warning, but the routine still goes on * to solve for X and compute error bounds as described below. * * 3. The system of equations is solved for X using the factored form * of A. * * 4. Iterative refinement is applied to improve the computed solution * matrix and calculate error bounds and backward error estimates * for it. * * Arguments * ========= * * FACT (input) CHARACTER*1 * Specifies whether or not the factored form of A has been * supplied on entry. * = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored * form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV * will not be modified. * = 'N': The matrix will be copied to DLF, DF, and DUF * and factored. * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations: * = 'N': A * X = B (No transpose) * = 'T': A**T * X = B (Transpose) * = 'C': A**H * X = B (Conjugate transpose = Transpose) * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * DL (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) subdiagonal elements of A. * * D (input) DOUBLE PRECISION array, dimension (N) * The n diagonal elements of A. * * DU (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) superdiagonal elements of A. * * DLF (input or output) DOUBLE PRECISION array, dimension (N-1) * If FACT = 'F', then DLF is an input argument and on entry * contains the (n-1) multipliers that define the matrix L from * the LU factorization of A as computed by DGTTRF. * * If FACT = 'N', then DLF is an output argument and on exit * contains the (n-1) multipliers that define the matrix L from * the LU factorization of A. * * DF (input or output) DOUBLE PRECISION array, dimension (N) * If FACT = 'F', then DF is an input argument and on entry * contains the n diagonal elements of the upper triangular * matrix U from the LU factorization of A. * * If FACT = 'N', then DF is an output argument and on exit * contains the n diagonal elements of the upper triangular * matrix U from the LU factorization of A. * * DUF (input or output) DOUBLE PRECISION array, dimension (N-1) * If FACT = 'F', then DUF is an input argument and on entry * contains the (n-1) elements of the first superdiagonal of U. * * If FACT = 'N', then DUF is an output argument and on exit * contains the (n-1) elements of the first superdiagonal of U. * * DU2 (input or output) DOUBLE PRECISION array, dimension (N-2) * If FACT = 'F', then DU2 is an input argument and on entry * contains the (n-2) elements of the second superdiagonal of * U. * * If FACT = 'N', then DU2 is an output argument and on exit * contains the (n-2) elements of the second superdiagonal of * U. * * IPIV (input or output) INTEGER array, dimension (N) * If FACT = 'F', then IPIV is an input argument and on entry * contains the pivot indices from the LU factorization of A as * computed by DGTTRF. * * If FACT = 'N', then IPIV is an output argument and on exit * contains the pivot indices from the LU factorization of A; * row i of the matrix was interchanged with row IPIV(i). * IPIV(i) will always be either i or i+1; IPIV(i) = i indicates * a row interchange was not required. * * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) * The N-by-NRHS right hand side matrix B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. * * LDX (input) INTEGER * The leading dimension of the array X. LDX >= max(1,N). * * RCOND (output) DOUBLE PRECISION * The estimate of the reciprocal condition number of the matrix * A. If RCOND is less than the machine precision (in * particular, if RCOND = 0), the matrix is singular to working * precision. This condition is indicated by a return code of * INFO > 0. * * FERR (output) DOUBLE PRECISION array, dimension (NRHS) * The estimated forward error bound for each solution vector * X(j) (the j-th column of the solution matrix X). * If XTRUE is the true solution corresponding to X(j), FERR(j) * is an estimated upper bound for the magnitude of the largest * element in (X(j) - XTRUE) divided by the magnitude of the * largest element in X(j). The estimate is as reliable as * the estimate for RCOND, and is almost always a slight * overestimate of the true error. * * BERR (output) DOUBLE PRECISION array, dimension (NRHS) * The componentwise relative backward error of each solution * vector X(j) (i.e., the smallest relative change in * any element of A or B that makes X(j) an exact solution). * * WORK (workspace) DOUBLE PRECISION array, dimension (3*N) * * IWORK (workspace) INTEGER 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, and i is * <= N: U(i,i) is exactly zero. The factorization * has not been completed unless i = N, but the * factor U is exactly singular, so the solution * and error bounds could not be computed. * RCOND = 0 is returned. * = N+1: U is nonsingular, but RCOND is less than machine * precision, meaning that the matrix is singular * to working precision. Nevertheless, the * solution and error bounds are computed because * there are a number of situations where the * computed solution can be more accurate than the * value of RCOND would suggest. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOFACT, NOTRAN CHARACTER NORM DOUBLE PRECISION ANORM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGT EXTERNAL LSAME, DLAMCH, DLANGT * .. * .. External Subroutines .. EXTERNAL DCOPY, DGTCON, DGTRFS, DGTTRF, DGTTRS, DLACPY, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * INFO = 0 NOFACT = LSAME( FACT, 'N' ) NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( NRHS.LT.0 ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -16 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGTSVX', -INFO ) RETURN END IF * IF( NOFACT ) THEN * * Compute the LU factorization of A. * CALL DCOPY( N, D, 1, DF, 1 ) IF( N.GT.1 ) THEN CALL DCOPY( N-1, DL, 1, DLF, 1 ) CALL DCOPY( N-1, DU, 1, DUF, 1 ) END IF CALL DGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO ) * * Return if INFO is non-zero. * IF( INFO.GT.0 )THEN RCOND = ZERO RETURN END IF END IF * * Compute the norm of the matrix A. * IF( NOTRAN ) THEN NORM = '1' ELSE NORM = 'I' END IF ANORM = DLANGT( NORM, N, DL, D, DU ) * * Compute the reciprocal of the condition number of A. * CALL DGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK, $ IWORK, INFO ) * * Compute the solution vectors X. * CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) CALL DGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX, $ INFO ) * * Use iterative refinement to improve the computed solutions and * compute error bounds and backward error estimates for them. * CALL DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, $ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * * Set INFO = N+1 if the matrix is singular to working precision. * IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) $ INFO = N + 1 * RETURN * * End of DGTSVX * END SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ) * .. * * Purpose * ======= * * DGTTRF computes an LU factorization of a real tridiagonal matrix A * using elimination with partial pivoting and row interchanges. * * The factorization has the form * A = L * U * where L is a product of permutation and unit lower bidiagonal * matrices and U is upper triangular with nonzeros in only the main * diagonal and first two superdiagonals. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. * * DL (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, DL must contain the (n-1) sub-diagonal elements of * A. * * On exit, DL is overwritten by the (n-1) multipliers that * define the matrix L from the LU factorization of A. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, D must contain the diagonal elements of A. * * On exit, D is overwritten by the n diagonal elements of the * upper triangular matrix U from the LU factorization of A. * * DU (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, DU must contain the (n-1) super-diagonal elements * of A. * * On exit, DU is overwritten by the (n-1) elements of the first * super-diagonal of U. * * DU2 (output) DOUBLE PRECISION array, dimension (N-2) * On exit, DU2 is overwritten by the (n-2) elements of the * second super-diagonal of U. * * IPIV (output) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was * interchanged with row IPIV(i). IPIV(i) will always be either * i or i+1; IPIV(i) = i indicates a row interchange was not * required. * * 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 ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION FACT, TEMP * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'DGTTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Initialize IPIV(i) = i and DU2(I) = 0 * DO 10 I = 1, N IPIV( I ) = I 10 CONTINUE DO 20 I = 1, N - 2 DU2( I ) = ZERO 20 CONTINUE * DO 30 I = 1, N - 2 IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN * * No row interchange required, eliminate DL(I) * IF( D( I ).NE.ZERO ) THEN FACT = DL( I ) / D( I ) DL( I ) = FACT D( I+1 ) = D( I+1 ) - FACT*DU( I ) END IF ELSE * * Interchange rows I and I+1, eliminate DL(I) * FACT = D( I ) / DL( I ) D( I ) = DL( I ) DL( I ) = FACT TEMP = DU( I ) DU( I ) = D( I+1 ) D( I+1 ) = TEMP - FACT*D( I+1 ) DU2( I ) = DU( I+1 ) DU( I+1 ) = -FACT*DU( I+1 ) IPIV( I ) = I + 1 END IF 30 CONTINUE IF( N.GT.1 ) THEN I = N - 1 IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN IF( D( I ).NE.ZERO ) THEN FACT = DL( I ) / D( I ) DL( I ) = FACT D( I+1 ) = D( I+1 ) - FACT*DU( I ) END IF ELSE FACT = D( I ) / DL( I ) D( I ) = DL( I ) DL( I ) = FACT TEMP = DU( I ) DU( I ) = D( I+1 ) D( I+1 ) = TEMP - FACT*D( I+1 ) IPIV( I ) = I + 1 END IF END IF * * Check for a zero on the diagonal of U. * DO 40 I = 1, N IF( D( I ).EQ.ZERO ) THEN INFO = I GO TO 50 END IF 40 CONTINUE 50 CONTINUE * RETURN * * End of DGTTRF * END SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. * * Purpose * ======= * * DGTTRS solves one of the systems of equations * A*X = B or A'*X = B, * with a tridiagonal matrix A using the LU factorization computed * by DGTTRF. * * Arguments * ========= * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations. * = 'N': A * X = B (No transpose) * = 'T': A'* X = B (Transpose) * = 'C': A'* X = B (Conjugate transpose = Transpose) * * N (input) INTEGER * The order of the matrix A. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * DL (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) multipliers that define the matrix L from the * LU factorization of A. * * D (input) DOUBLE PRECISION array, dimension (N) * The n diagonal elements of the upper triangular matrix U from * the LU factorization of A. * * DU (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) elements of the first super-diagonal of U. * * DU2 (input) DOUBLE PRECISION array, dimension (N-2) * The (n-2) elements of the second super-diagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was * interchanged with row IPIV(i). IPIV(i) will always be either * i or i+1; IPIV(i) = i indicates a row interchange was not * required. * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the matrix of right hand side vectors B. * On exit, B is overwritten by the solution vectors X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. LOGICAL NOTRAN INTEGER ITRANS, J, JB, NB * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. External Subroutines .. EXTERNAL DGTTS2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * INFO = 0 NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' ) IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ. $ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGTTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * * Decode TRANS * IF( NOTRAN ) THEN ITRANS = 0 ELSE ITRANS = 1 END IF * * Determine the number of right-hand sides to solve at a time. * IF( NRHS.EQ.1 ) THEN NB = 1 ELSE NB = MAX( 1, ILAENV( 1, 'DGTTRS', TRANS, N, NRHS, -1, -1 ) ) END IF * IF( NB.GE.NRHS ) THEN CALL DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) ELSE DO 10 J = 1, NRHS, NB JB = MIN( NRHS-J+1, NB ) CALL DGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ), $ LDB ) 10 CONTINUE END IF * * End of DGTTRS * END SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), $ WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * DHGEQZ computes the eigenvalues of a real matrix pair (H,T), * where H is an upper Hessenberg matrix and T is upper triangular, * using the double-shift QZ method. * Matrix pairs of this type are produced by the reduction to * generalized upper Hessenberg form of a real matrix pair (A,B): * * A = Q1*H*Z1**T, B = Q1*T*Z1**T, * * as computed by DGGHRD. * * If JOB='S', then the Hessenberg-triangular pair (H,T) is * also reduced to generalized Schur form, * * H = Q*S*Z**T, T = Q*P*Z**T, * * where Q and Z are orthogonal matrices, P is an upper triangular * matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 * diagonal blocks. * * The 1-by-1 blocks correspond to real eigenvalues of the matrix pair * (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of * eigenvalues. * * Additionally, the 2-by-2 upper triangular diagonal blocks of P * corresponding to 2-by-2 blocks of S are reduced to positive diagonal * form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, * P(j,j) > 0, and P(j+1,j+1) > 0. * * Optionally, the orthogonal matrix Q from the generalized Schur * factorization may be postmultiplied into an input matrix Q1, and the * orthogonal matrix Z may be postmultiplied into an input matrix Z1. * If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced * the matrix pair (A,B) to generalized upper Hessenberg form, then the * output matrices Q1*Q and Z1*Z are the orthogonal factors from the * generalized Schur factorization of (A,B): * * A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. * * To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, * of (A,B)) are computed as a pair of values (alpha,beta), where alpha is * complex and beta real. * If beta is nonzero, lambda = alpha / beta is an eigenvalue of the * generalized nonsymmetric eigenvalue problem (GNEP) * A*x = lambda*B*x * and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the * alternate form of the GNEP * mu*A*y = B*y. * Real eigenvalues can be read directly from the generalized Schur * form: * alpha = S(i,i), beta = P(i,i). * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), * pp. 241--256. * * Arguments * ========= * * JOB (input) CHARACTER*1 * = 'E': Compute eigenvalues only; * = 'S': Compute eigenvalues and the Schur form. * * COMPQ (input) CHARACTER*1 * = 'N': Left Schur vectors (Q) are not computed; * = 'I': Q is initialized to the unit matrix and the matrix Q * of left Schur vectors of (H,T) is returned; * = 'V': Q must contain an orthogonal matrix Q1 on entry and * the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 * = 'N': Right Schur vectors (Z) are not computed; * = 'I': Z is initialized to the unit matrix and the matrix Z * of right Schur vectors of (H,T) is returned; * = 'V': Z must contain an orthogonal matrix Z1 on entry and * the product Z1*Z is returned. * * N (input) INTEGER * The order of the matrices H, T, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * ILO and IHI mark the rows and columns of H which are in * Hessenberg form. It is assumed that A is already upper * triangular in rows and columns 1:ILO-1 and IHI+1:N. * If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. * * H (input/output) DOUBLE PRECISION array, dimension (LDH, N) * On entry, the N-by-N upper Hessenberg matrix H. * On exit, if JOB = 'S', H contains the upper quasi-triangular * matrix S from the generalized Schur factorization; * 2-by-2 diagonal blocks (corresponding to complex conjugate * pairs of eigenvalues) are returned in standard form, with * H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. * If JOB = 'E', the diagonal blocks of H match those of S, but * the rest of H is unspecified. * * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max( 1, N ). * * T (input/output) DOUBLE PRECISION array, dimension (LDT, N) * On entry, the N-by-N upper triangular matrix T. * On exit, if JOB = 'S', T contains the upper triangular * matrix P from the generalized Schur factorization; * 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S * are reduced to positive diagonal form, i.e., if H(j+1,j) is * non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and * T(j+1,j+1) > 0. * If JOB = 'E', the diagonal blocks of T match those of P, but * the rest of T is unspecified. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max( 1, N ). * * ALPHAR (output) DOUBLE PRECISION array, dimension (N) * The real parts of each scalar alpha defining an eigenvalue * of GNEP. * * ALPHAI (output) DOUBLE PRECISION array, dimension (N) * The imaginary parts of each scalar alpha defining an * eigenvalue of GNEP. * If ALPHAI(j) is zero, then the j-th eigenvalue is real; if * positive, then the j-th and (j+1)-st eigenvalues are a * complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). * * BETA (output) DOUBLE PRECISION array, dimension (N) * The scalars beta that define the eigenvalues of GNEP. * Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and * beta = BETA(j) represent the j-th eigenvalue of the matrix * pair (A,B), in one of the forms lambda = alpha/beta or * mu = beta/alpha. Since either lambda or mu may overflow, * they should not, in general, be computed. * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) * On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in * the reduction of (A,B) to generalized Hessenberg form. * On exit, if COMPZ = 'I', the orthogonal matrix of left Schur * vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix * of left Schur vectors of (A,B). * Not referenced if COMPZ = 'N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) * On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in * the reduction of (A,B) to generalized Hessenberg form. * On exit, if COMPZ = 'I', the orthogonal matrix of * right Schur vectors of (H,T), and if COMPZ = 'V', the * orthogonal matrix of right Schur vectors of (A,B). * Not referenced if COMPZ = 'N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. * If COMPZ='V' or 'I', then LDZ >= N. * * 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 >= max(1,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. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * = 1,...,N: the QZ iteration did not converge. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO+1,...,N should be correct. * = N+1,...,2*N: the shift calculation failed. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO-N+1,...,N should be correct. * * Further Details * =============== * * Iteration counters: * * JITER -- counts iterations. * IITER -- counts iterations run since ILAST was last * changed. This is therefore reset only when a 1-by-1 or * 2-by-2 block deflates off the bottom. * * ===================================================================== * * .. Parameters .. * $ SAFETY = 1.0E+0 ) DOUBLE PRECISION HALF, ZERO, ONE, SAFETY PARAMETER ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0, $ SAFETY = 1.0D+2 ) * .. * .. Local Scalars .. LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ, $ LQUERY INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, $ JR, MAXIT DOUBLE PRECISION A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11, $ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L, $ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I, $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, $ WR2 * .. * .. Local Arrays .. DOUBLE PRECISION V( 3 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2, DLAPY3 EXTERNAL LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3 * .. * .. External Subroutines .. EXTERNAL DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. * * Decode JOB, COMPQ, COMPZ * IF( LSAME( JOB, 'E' ) ) THEN ILSCHR = .FALSE. ISCHUR = 1 ELSE IF( LSAME( JOB, 'S' ) ) THEN ILSCHR = .TRUE. ISCHUR = 2 ELSE ISCHUR = 0 END IF * IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF * IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF * * Check Argument Values * INFO = 0 WORK( 1 ) = MAX( 1, N ) LQUERY = ( LWORK.EQ.-1 ) IF( ISCHUR.EQ.0 ) THEN INFO = -1 ELSE IF( ICOMPQ.EQ.0 ) THEN INFO = -2 ELSE IF( ICOMPZ.EQ.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( ILO.LT.1 ) THEN INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 ELSE IF( LDH.LT.N ) THEN INFO = -8 ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -15 ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN INFO = -17 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -19 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DHGEQZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = DBLE( 1 ) RETURN END IF * * Initialize Q and Z * IF( ICOMPQ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * * Machine Constants * IN = IHI + 1 - ILO SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) BSCALE = ONE / MAX( SAFMIN, BNORM ) * * Set Eigenvalues IHI+1:N * DO 30 J = IHI + 1, N IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 10 JR = 1, J H( JR, J ) = -H( JR, J ) T( JR, J ) = -T( JR, J ) 10 CONTINUE ELSE H( J, J ) = -H( J, J ) T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 20 JR = 1, N Z( JR, J ) = -Z( JR, J ) 20 CONTINUE END IF END IF ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO BETA( J ) = T( J, J ) 30 CONTINUE * * If IHI < ILO, skip QZ steps * IF( IHI.LT.ILO ) $ GO TO 380 * * MAIN QZ ITERATION LOOP * * Initialize dynamic indices * * Eigenvalues ILAST+1:N have been found. * Column operations modify rows IFRSTM:whatever. * Row operations modify columns whatever:ILASTM. * * If only eigenvalues are being computed, then * IFRSTM is the row of the last splitting row above row ILAST; * this is always at least ILO. * IITER counts iterations since the last eigenvalue was found, * to tell when to use an extraordinary shift. * MAXIT is the maximum number of QZ sweeps allowed. * ILAST = IHI IF( ILSCHR ) THEN IFRSTM = 1 ILASTM = N ELSE IFRSTM = ILO ILASTM = IHI END IF IITER = 0 ESHIFT = ZERO MAXIT = 30*( IHI-ILO+1 ) * DO 360 JITER = 1, MAXIT * * Split the matrix if possible. * * Two tests: * 1: H(j,j-1)=0 or j=ILO * 2: T(j,j)=0 * IF( ILAST.EQ.ILO ) THEN * * Special case: j=ILAST * GO TO 80 ELSE IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN H( ILAST, ILAST-1 ) = ZERO GO TO 80 END IF END IF * IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN T( ILAST, ILAST ) = ZERO GO TO 70 END IF * * General case: j unfl ) * __ * (sA - wB) ( CZ -SZ ) * ( SZ CZ ) * C11R = S1*A11 - WR*B11 C11I = -WI*B11 C12 = S1*A12 C21 = S1*A21 C22R = S1*A22 - WR*B22 C22I = -WI*B22 * IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ $ ABS( C22R )+ABS( C22I ) ) THEN T1 = DLAPY3( C12, C11R, C11I ) CZ = C12 / T1 SZR = -C11R / T1 SZI = -C11I / T1 ELSE CZ = DLAPY2( C22R, C22I ) IF( CZ.LE.SAFMIN ) THEN CZ = ZERO SZR = ONE SZI = ZERO ELSE TEMPR = C22R / CZ TEMPI = C22I / CZ T1 = DLAPY2( CZ, C21 ) CZ = CZ / T1 SZR = -C21*TEMPR / T1 SZI = C21*TEMPI / T1 END IF END IF * * Compute Givens rotation on left * * ( CQ SQ ) * ( __ ) A or B * ( -SQ CQ ) * AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 ) BN = ABS( B11 ) + ABS( B22 ) WABS = ABS( WR ) + ABS( WI ) IF( S1*AN.GT.WABS*BN ) THEN CQ = CZ*B11 SQR = SZR*B22 SQI = -SZI*B22 ELSE A1R = CZ*A11 + SZR*A12 A1I = SZI*A12 A2R = CZ*A21 + SZR*A22 A2I = SZI*A22 CQ = DLAPY2( A1R, A1I ) IF( CQ.LE.SAFMIN ) THEN CQ = ZERO SQR = ONE SQI = ZERO ELSE TEMPR = A1R / CQ TEMPI = A1I / CQ SQR = TEMPR*A2R + TEMPI*A2I SQI = TEMPI*A2R - TEMPR*A2I END IF END IF T1 = DLAPY3( CQ, SQR, SQI ) CQ = CQ / T1 SQR = SQR / T1 SQI = SQI / T1 * * Compute diagonal elements of QBZ * TEMPR = SQR*SZR - SQI*SZI TEMPI = SQR*SZI + SQI*SZR B1R = CQ*CZ*B11 + TEMPR*B22 B1I = TEMPI*B22 B1A = DLAPY2( B1R, B1I ) B2R = CQ*CZ*B22 + TEMPR*B11 B2I = -TEMPI*B11 B2A = DLAPY2( B2R, B2I ) * * Normalize so beta > 0, and Im( alpha1 ) > 0 * BETA( ILAST-1 ) = B1A BETA( ILAST ) = B2A ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV ALPHAR( ILAST ) = ( WR*B2A )*S1INV ALPHAI( ILAST ) = -( WI*B2A )*S1INV * * Step 3: Go to next block -- exit if finished. * ILAST = IFIRST - 1 IF( ILAST.LT.ILO ) $ GO TO 380 * * Reset counters * IITER = 0 ESHIFT = ZERO IF( .NOT.ILSCHR ) THEN ILASTM = ILAST IF( IFRSTM.GT.ILAST ) $ IFRSTM = ILO END IF GO TO 350 ELSE * * Usual case: 3x3 or larger block, using Francis implicit * double-shift * * 2 * Eigenvalue equation is w - c w + d = 0, * * -1 2 -1 * so compute 1st column of (A B ) - c A B + d * using the formula in QZIT (from EISPACK) * * We assume that the block is at least 3x3 * AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / $ ( BSCALE*T( ILAST, ILAST ) ) AD22 = ( ASCALE*H( ILAST, ILAST ) ) / $ ( BSCALE*T( ILAST, ILAST ) ) U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / $ ( BSCALE*T( IFIRST, IFIRST ) ) AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / $ ( BSCALE*T( IFIRST, IFIRST ) ) AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) * V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )- $ ( AD22-AD11L )+AD21*U12 )*AD21L V( 3 ) = AD32L*AD21L * ISTART = IFIRST * CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE * * Sweep * DO 290 J = ISTART, ILAST - 2 * * All but last elements: use 3x3 Householder transforms. * * Zero (j-1)st column of A * IF( J.GT.ISTART ) THEN V( 1 ) = H( J, J-1 ) V( 2 ) = H( J+1, J-1 ) V( 3 ) = H( J+2, J-1 ) * CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE H( J+1, J-1 ) = ZERO H( J+2, J-1 ) = ZERO END IF * DO 230 JC = J, ILASTM TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* $ H( J+2, JC ) ) H( J, JC ) = H( J, JC ) - TEMP H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* $ T( J+2, JC ) ) T( J, JC ) = T( J, JC ) - TEMP2 T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) 230 CONTINUE IF( ILQ ) THEN DO 240 JR = 1, N TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* $ Q( JR, J+2 ) ) Q( JR, J ) = Q( JR, J ) - TEMP Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 ) Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 ) 240 CONTINUE END IF * * Zero j-th column of B (see DLAGBC for details) * * Swap rows to pivot * ILPIVT = .FALSE. TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN SCALE = ZERO U1 = ONE U2 = ZERO GO TO 250 ELSE IF( TEMP.GE.TEMP2 ) THEN W11 = T( J+1, J+1 ) W21 = T( J+2, J+1 ) W12 = T( J+1, J+2 ) W22 = T( J+2, J+2 ) U1 = T( J+1, J ) U2 = T( J+2, J ) ELSE W21 = T( J+1, J+1 ) W11 = T( J+2, J+1 ) W22 = T( J+1, J+2 ) W12 = T( J+2, J+2 ) U2 = T( J+1, J ) U1 = T( J+2, J ) END IF * * Swap columns if nec. * IF( ABS( W12 ).GT.ABS( W11 ) ) THEN ILPIVT = .TRUE. TEMP = W12 TEMP2 = W22 W12 = W11 W22 = W21 W11 = TEMP W21 = TEMP2 END IF * * LU-factor * TEMP = W21 / W11 U2 = U2 - TEMP*U1 W22 = W22 - TEMP*W12 W21 = ZERO * * Compute SCALE * SCALE = ONE IF( ABS( W22 ).LT.SAFMIN ) THEN SCALE = ZERO U2 = ONE U1 = -W12 / W11 GO TO 250 END IF IF( ABS( W22 ).LT.ABS( U2 ) ) $ SCALE = ABS( W22 / U2 ) IF( ABS( W11 ).LT.ABS( U1 ) ) $ SCALE = MIN( SCALE, ABS( W11 / U1 ) ) * * Solve * U2 = ( SCALE*U2 ) / W22 U1 = ( SCALE*U1-W12*U2 ) / W11 * 250 CONTINUE IF( ILPIVT ) THEN TEMP = U2 U2 = U1 U1 = TEMP END IF * * Compute Householder Vector * T1 = SQRT( SCALE**2+U1**2+U2**2 ) TAU = ONE + SCALE / T1 VS = -ONE / ( SCALE+T1 ) V( 1 ) = ONE V( 2 ) = VS*U1 V( 3 ) = VS*U2 * * Apply transformations from the right. * DO 260 JR = IFRSTM, MIN( J+3, ILAST ) TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* $ H( JR, J+2 ) ) H( JR, J ) = H( JR, J ) - TEMP H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) 260 CONTINUE DO 270 JR = IFRSTM, J + 2 TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* $ T( JR, J+2 ) ) T( JR, J ) = T( JR, J ) - TEMP T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) 270 CONTINUE IF( ILZ ) THEN DO 280 JR = 1, N TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* $ Z( JR, J+2 ) ) Z( JR, J ) = Z( JR, J ) - TEMP Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 ) Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) 280 CONTINUE END IF T( J+1, J ) = ZERO T( J+2, J ) = ZERO 290 CONTINUE * * Last elements: Use Givens rotations * * Rotations from the left * J = ILAST - 1 TEMP = H( J, J-1 ) CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) H( J+1, J-1 ) = ZERO * DO 300 JC = J, ILASTM TEMP = C*H( J, JC ) + S*H( J+1, JC ) H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) H( J, JC ) = TEMP TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) T( J, JC ) = TEMP2 300 CONTINUE IF( ILQ ) THEN DO 310 JR = 1, N TEMP = C*Q( JR, J ) + S*Q( JR, J+1 ) Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 ) Q( JR, J ) = TEMP 310 CONTINUE END IF * * Rotations from the right. * TEMP = T( J+1, J+1 ) CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) T( J+1, J ) = ZERO * DO 320 JR = IFRSTM, ILAST TEMP = C*H( JR, J+1 ) + S*H( JR, J ) H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) H( JR, J+1 ) = TEMP 320 CONTINUE DO 330 JR = IFRSTM, ILAST - 1 TEMP = C*T( JR, J+1 ) + S*T( JR, J ) T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) T( JR, J+1 ) = TEMP 330 CONTINUE IF( ILZ ) THEN DO 340 JR = 1, N TEMP = C*Z( JR, J+1 ) + S*Z( JR, J ) Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J ) Z( JR, J+1 ) = TEMP 340 CONTINUE END IF * * End of Double-Shift code * END IF * GO TO 350 * * End of iteration loop * 350 CONTINUE 360 CONTINUE * * Drop-through = non-convergence * INFO = ILAST GO TO 420 * * Successful completion of all QZ steps * 380 CONTINUE * * Set Eigenvalues 1:ILO-1 * DO 410 J = 1, ILO - 1 IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 390 JR = 1, J H( JR, J ) = -H( JR, J ) T( JR, J ) = -T( JR, J ) 390 CONTINUE ELSE H( J, J ) = -H( J, J ) T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 400 JR = 1, N Z( JR, J ) = -Z( JR, J ) 400 CONTINUE END IF END IF ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO BETA( J ) = T( J, J ) 410 CONTINUE * * Normal Termination * INFO = 0 * * Exit (other than argument error) -- return optimal workspace size * 420 CONTINUE WORK( 1 ) = DBLE( N ) RETURN * * End of DHGEQZ * END SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, $ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, $ IFAILR, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER EIGSRC, INITV, SIDE INTEGER INFO, LDH, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IFAILL( * ), IFAILR( * ) DOUBLE PRECISION H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ), $ WI( * ), WORK( * ), WR( * ) * .. * * Purpose * ======= * * DHSEIN uses inverse iteration to find specified right and/or left * eigenvectors of a real upper Hessenberg matrix H. * * The right eigenvector x and the left eigenvector y of the matrix H * corresponding to an eigenvalue w are defined by: * * H * x = w * x, y**h * H = w * y**h * * where y**h denotes the conjugate transpose of the vector y. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'R': compute right eigenvectors only; * = 'L': compute left eigenvectors only; * = 'B': compute both right and left eigenvectors. * * EIGSRC (input) CHARACTER*1 * Specifies the source of eigenvalues supplied in (WR,WI): * = 'Q': the eigenvalues were found using DHSEQR; thus, if * H has zero subdiagonal elements, and so is * block-triangular, then the j-th eigenvalue can be * assumed to be an eigenvalue of the block containing * the j-th row/column. This property allows DHSEIN to * perform inverse iteration on just one diagonal block. * = 'N': no assumptions are made on the correspondence * between eigenvalues and diagonal blocks. In this * case, DHSEIN must always perform inverse iteration * using the whole matrix H. * * INITV (input) CHARACTER*1 * = 'N': no initial vectors are supplied; * = 'U': user-supplied initial vectors are stored in the arrays * VL and/or VR. * * SELECT (input/output) LOGICAL array, dimension (N) * Specifies the eigenvectors to be computed. To select the * real eigenvector corresponding to a real eigenvalue WR(j), * SELECT(j) must be set to .TRUE.. To select the complex * eigenvector corresponding to a complex eigenvalue * (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)), * either SELECT(j) or SELECT(j+1) or both must be set to * .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is * .FALSE.. * * N (input) INTEGER * The order of the matrix H. N >= 0. * * H (input) DOUBLE PRECISION array, dimension (LDH,N) * The upper Hessenberg matrix H. * * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * * WR (input/output) DOUBLE PRECISION array, dimension (N) * WI (input) DOUBLE PRECISION array, dimension (N) * On entry, the real and imaginary parts of the eigenvalues of * H; a complex conjugate pair of eigenvalues must be stored in * consecutive elements of WR and WI. * On exit, WR may have been altered since close eigenvalues * are perturbed slightly in searching for independent * eigenvectors. * * VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) * On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must * contain starting vectors for the inverse iteration for the * left eigenvectors; the starting vector for each eigenvector * must be in the same column(s) in which the eigenvector will * be stored. * On exit, if SIDE = 'L' or 'B', the left eigenvectors * specified by SELECT will be stored consecutively in the * columns of VL, in the same order as their eigenvalues. A * complex eigenvector corresponding to a complex eigenvalue is * stored in two consecutive columns, the first holding the real * part and the second the imaginary part. * If SIDE = 'R', VL is not referenced. * * LDVL (input) INTEGER * The leading dimension of the array VL. * LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must * contain starting vectors for the inverse iteration for the * right eigenvectors; the starting vector for each eigenvector * must be in the same column(s) in which the eigenvector will * be stored. * On exit, if SIDE = 'R' or 'B', the right eigenvectors * specified by SELECT will be stored consecutively in the * columns of VR, in the same order as their eigenvalues. A * complex eigenvector corresponding to a complex eigenvalue is * stored in two consecutive columns, the first holding the real * part and the second the imaginary part. * If SIDE = 'L', VR is not referenced. * * LDVR (input) INTEGER * The leading dimension of the array VR. * LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. * * M (output) INTEGER * The number of columns in the arrays VL and/or VR required to * store the eigenvectors; each selected real eigenvector * occupies one column and each selected complex eigenvector * occupies two columns. * * WORK (workspace) DOUBLE PRECISION array, dimension ((N+2)*N) * * IFAILL (output) INTEGER array, dimension (MM) * If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left * eigenvector in the i-th column of VL (corresponding to the * eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the * eigenvector converged satisfactorily. If the i-th and (i+1)th * columns of VL hold a complex eigenvector, then IFAILL(i) and * IFAILL(i+1) are set to the same value. * If SIDE = 'R', IFAILL is not referenced. * * IFAILR (output) INTEGER array, dimension (MM) * If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right * eigenvector in the i-th column of VR (corresponding to the * eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the * eigenvector converged satisfactorily. If the i-th and (i+1)th * columns of VR hold a complex eigenvector, then IFAILR(i) and * IFAILR(i+1) are set to the same value. * If SIDE = 'L', IFAILR 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, i is the number of eigenvectors which * failed to converge; see IFAILL and IFAILR for further * details. * * Further Details * =============== * * Each eigenvector is normalized so that the element of largest * magnitude has magnitude 1; here the magnitude of a complex number * (x,y) is taken to be |x|+|y|. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV INTEGER I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK DOUBLE PRECISION BIGNUM, EPS3, HNORM, SMLNUM, ULP, UNFL, WKI, $ WKR * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL LSAME, DLAMCH, DLANHS * .. * .. External Subroutines .. EXTERNAL DLAEIN, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * * Decode and test the input parameters. * BOTHV = LSAME( SIDE, 'B' ) RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV * FROMQR = LSAME( EIGSRC, 'Q' ) * NOINIT = LSAME( INITV, 'N' ) * * Set M to the number of columns required to store the selected * eigenvectors, and standardize the array SELECT. * M = 0 PAIR = .FALSE. DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. SELECT( K ) = .FALSE. ELSE IF( WI( K ).EQ.ZERO ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( K ) .OR. SELECT( K+1 ) ) THEN SELECT( K ) = .TRUE. M = M + 2 END IF END IF END IF 10 CONTINUE * INFO = 0 IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -1 ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN INFO = -2 ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN INFO = -11 ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN INFO = -13 ELSE IF( MM.LT.M ) THEN INFO = -14 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DHSEIN', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * Set machine-dependent constants. * UNFL = DLAMCH( 'Safe minimum' ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( N / ULP ) BIGNUM = ( ONE-ULP ) / SMLNUM * LDWORK = N + 1 * KL = 1 KLN = 0 IF( FROMQR ) THEN KR = 0 ELSE KR = N END IF KSR = 1 * DO 120 K = 1, N IF( SELECT( K ) ) THEN * * Compute eigenvector(s) corresponding to W(K). * IF( FROMQR ) THEN * * If affiliation of eigenvalues is known, check whether * the matrix splits. * * Determine KL and KR such that 1 <= KL <= K <= KR <= N * and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or * KR = N). * * Then inverse iteration can be performed with the * submatrix H(KL:N,KL:N) for a left eigenvector, and with * the submatrix H(1:KR,1:KR) for a right eigenvector. * DO 20 I = K, KL + 1, -1 IF( H( I, I-1 ).EQ.ZERO ) $ GO TO 30 20 CONTINUE 30 CONTINUE KL = I IF( K.GT.KR ) THEN DO 40 I = K, N - 1 IF( H( I+1, I ).EQ.ZERO ) $ GO TO 50 40 CONTINUE 50 CONTINUE KR = I END IF END IF * IF( KL.NE.KLN ) THEN KLN = KL * * Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it * has not ben computed before. * HNORM = DLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK ) IF( HNORM.GT.ZERO ) THEN EPS3 = HNORM*ULP ELSE EPS3 = SMLNUM END IF END IF * * Perturb eigenvalue if it is close to any previous * selected eigenvalues affiliated to the submatrix * H(KL:KR,KL:KR). Close roots are modified by EPS3. * WKR = WR( K ) WKI = WI( K ) 60 CONTINUE DO 70 I = K - 1, KL, -1 IF( SELECT( I ) .AND. ABS( WR( I )-WKR )+ $ ABS( WI( I )-WKI ).LT.EPS3 ) THEN WKR = WKR + EPS3 GO TO 60 END IF 70 CONTINUE WR( K ) = WKR * PAIR = WKI.NE.ZERO IF( PAIR ) THEN KSI = KSR + 1 ELSE KSI = KSR END IF IF( LEFTV ) THEN * * Compute left eigenvector. * CALL DLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH, $ WKR, WKI, VL( KL, KSR ), VL( KL, KSI ), $ WORK, LDWORK, WORK( N*N+N+1 ), EPS3, SMLNUM, $ BIGNUM, IINFO ) IF( IINFO.GT.0 ) THEN IF( PAIR ) THEN INFO = INFO + 2 ELSE INFO = INFO + 1 END IF IFAILL( KSR ) = K IFAILL( KSI ) = K ELSE IFAILL( KSR ) = 0 IFAILL( KSI ) = 0 END IF DO 80 I = 1, KL - 1 VL( I, KSR ) = ZERO 80 CONTINUE IF( PAIR ) THEN DO 90 I = 1, KL - 1 VL( I, KSI ) = ZERO 90 CONTINUE END IF END IF IF( RIGHTV ) THEN * * Compute right eigenvector. * CALL DLAEIN( .TRUE., NOINIT, KR, H, LDH, WKR, WKI, $ VR( 1, KSR ), VR( 1, KSI ), WORK, LDWORK, $ WORK( N*N+N+1 ), EPS3, SMLNUM, BIGNUM, $ IINFO ) IF( IINFO.GT.0 ) THEN IF( PAIR ) THEN INFO = INFO + 2 ELSE INFO = INFO + 1 END IF IFAILR( KSR ) = K IFAILR( KSI ) = K ELSE IFAILR( KSR ) = 0 IFAILR( KSI ) = 0 END IF DO 100 I = KR + 1, N VR( I, KSR ) = ZERO 100 CONTINUE IF( PAIR ) THEN DO 110 I = KR + 1, N VR( I, KSI ) = ZERO 110 CONTINUE END IF END IF * IF( PAIR ) THEN KSR = KSR + 2 ELSE KSR = KSR + 1 END IF END IF 120 CONTINUE * RETURN * * End of DHSEIN * END SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, WORK, LWORK, INFO ) * * -- LAPACK driver routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N CHARACTER COMPZ, JOB * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. * Purpose * ======= * * DHSEQR computes the eigenvalues of a Hessenberg matrix H * and, optionally, the matrices T and Z from the Schur decomposition * H = Z T Z**T, where T is an upper quasi-triangular matrix (the * Schur form), and Z is the orthogonal matrix of Schur vectors. * * Optionally Z may be postmultiplied into an input orthogonal * matrix Q so that this routine can give the Schur factorization * of a matrix A which has been reduced to the Hessenberg form H * by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. * * Arguments * ========= * * JOB (input) CHARACTER*1 * = 'E': compute eigenvalues only; * = 'S': compute eigenvalues and the Schur form T. * * COMPZ (input) CHARACTER*1 * = 'N': no Schur vectors are computed; * = 'I': Z is initialized to the unit matrix and the matrix Z * of Schur vectors of H is returned; * = 'V': Z must contain an orthogonal matrix Q on entry, and * the product Q*Z is returned. * * N (input) INTEGER * The order of the matrix H. N .GE. 0. * * 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. ILO and IHI are normally * set by a previous call to DGEBAL, and then passed to DGEHRD * when the matrix output by DGEBAL is reduced to Hessenberg * form. Otherwise ILO and IHI should be set to 1 and N * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. * If N = 0, then ILO = 1 and IHI = 0. * * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. * On exit, if INFO = 0 and JOB = 'S', then H contains the * upper quasi-triangular matrix T from the Schur decomposition * (the Schur form); 2-by-2 diagonal blocks (corresponding to * complex conjugate pairs of eigenvalues) are returned in * standard form, with H(i,i) = H(i+1,i+1) and * H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the * contents of H are unspecified on exit. (The output value of * H when INFO.GT.0 is given under the description of INFO * below.) * * Unlike earlier versions of DHSEQR, this subroutine may * explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 * or j = IHI+1, IHI+2, ... N. * * LDH (input) INTEGER * The leading dimension of the array H. LDH .GE. max(1,N). * * WR (output) DOUBLE PRECISION array, dimension (N) * WI (output) DOUBLE PRECISION array, dimension (N) * The real and imaginary parts, respectively, of the computed * eigenvalues. If two eigenvalues are computed as a complex * conjugate pair, they are stored in consecutive elements of * WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and * WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in * the same order as on the diagonal of the Schur form returned * in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 * diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and * WI(i+1) = -WI(i). * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) * If COMPZ = 'N', Z is not referenced. * If COMPZ = 'I', on entry Z need not be set and on exit, * if INFO = 0, Z contains the orthogonal matrix Z of the Schur * vectors of H. If COMPZ = 'V', on entry Z must contain an * N-by-N matrix Q, which is assumed to be equal to the unit * matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, * if INFO = 0, Z contains Q*Z. * Normally Q is the orthogonal matrix generated by DORGHR * after the call to DGEHRD which formed the Hessenberg matrix * H. (The output value of Z when INFO.GT.0 is given under * the description of INFO below.) * * LDZ (input) INTEGER * The leading dimension of the array Z. if COMPZ = 'I' or * COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns an estimate of * the optimal value for LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK .GE. max(1,N) * is sufficient, but LWORK typically as large as 6*N may * be required for optimal performance. A workspace query * to determine the optimal workspace size is recommended. * * If LWORK = -1, then DHSEQR does a workspace query. * In this case, DHSEQR checks the input parameters and * estimates the optimal workspace size for the given * values of N, ILO and IHI. The estimate is returned * in WORK(1). No error message related to LWORK is * issued by XERBLA. Neither H nor Z are accessed. * * * INFO (output) INTEGER * = 0: successful exit * .LT. 0: if INFO = -i, the i-th argument had an illegal * value * .GT. 0: if INFO = i, DHSEQR failed to compute all of * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR * and WI contain those eigenvalues which have been * successfully computed. (Failures are rare.) * * If INFO .GT. 0 and JOB = 'E', then on exit, the * remaining unconverged eigenvalues are the eigen- * values of the upper Hessenberg matrix rows and * columns ILO through INFO of the final, output * value of H. * * If INFO .GT. 0 and JOB = 'S', then on exit * * (*) (initial value of H)*U = U*(final value of H) * * where U is an orthogonal matrix. The final * value of H is upper Hessenberg and quasi-triangular * in rows and columns INFO+1 through IHI. * * If INFO .GT. 0 and COMPZ = 'V', then on exit * * (final value of Z) = (initial value of Z)*U * * where U is the orthogonal matrix in (*) (regard- * less of the value of JOB.) * * If INFO .GT. 0 and COMPZ = 'I', then on exit * (final value of Z) = U * where U is the orthogonal matrix in (*) (regard- * less of the value of JOB.) * * If INFO .GT. 0 and COMPZ = 'N', then Z is not * accessed. * * ================================================================ * Default values supplied by * ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). * It is suggested that these defaults be adjusted in order * to attain best performance in each particular * computational environment. * * ISPEC=1: The DLAHQR vs DLAQR0 crossover point. * Default: 75. (Must be at least 11.) * * ISPEC=2: Recommended deflation window size. * This depends on ILO, IHI and NS. NS is the * number of simultaneous shifts returned * by ILAENV(ISPEC=4). (See ISPEC=4 below.) * The default for (IHI-ILO+1).LE.500 is NS. * The default for (IHI-ILO+1).GT.500 is 3*NS/2. * * ISPEC=3: Nibble crossover point. (See ILAENV for * details.) Default: 14% of deflation window * size. * * ISPEC=4: Number of simultaneous shifts, NS, in * a multi-shift QR iteration. * * If IHI-ILO+1 is ... * * greater than ...but less ... the * or equal to ... than default is * * 1 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 some or all matrices of this order * are passed to the implicit double shift routine * DLAHQR and NS is ignored. See ISPEC=1 above * and comments in IPARM for details. * * The asterisks (**) indicate an ad-hoc * function of N increasing from 10 to 64. * * ISPEC=5: Select structured matrix multiply. * (See ILAENV for details.) Default: 3. * * ================================================================ * Based on contributions by * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * * ================================================================ * References: * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 * Performance, SIAM Journal of Matrix Analysis, volume 23, pages * 929--947, 2002. * * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR * Algorithm Part II: Aggressive Early Deflation, SIAM Journal * of Matrix Analysis, volume 23, pages 948--973, 2002. * * ================================================================ * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . DLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== * * ==== NL allocates some local workspace to help small matrices * . through a rare DLAHQR failure. NL .GT. NTINY = 11 is * . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom- * . mended. (The default value of NMIN is 75.) Using NL = 49 * . allows up to six simultaneous shifts and a 16-by-16 * . deflation window. ==== * INTEGER NTINY PARAMETER ( NTINY = 11 ) INTEGER NL PARAMETER ( NL = 49 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) * .. * .. Local Arrays .. DOUBLE PRECISION HL( NL, NL ), WORKL( NL ) * .. * .. Local Scalars .. INTEGER I, KBOT, NMIN LOGICAL INITZ, LQUERY, WANTT, WANTZ * .. * .. External Functions .. INTEGER ILAENV LOGICAL LSAME EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. EXTERNAL DLACPY, DLAHQR, DLAQR0, DLASET, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Executable Statements .. * * ==== Decode and check the input parameters. ==== * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) WORK( 1 ) = DBLE( MAX( 1, N ) ) LQUERY = LWORK.EQ.-1 * INFO = 0 IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.NE.0 ) THEN * * ==== Quick return in case of invalid argument. ==== * CALL XERBLA( 'DHSEQR', -INFO ) RETURN * ELSE IF( N.EQ.0 ) THEN * * ==== Quick return in case N = 0; nothing to do. ==== * RETURN * ELSE IF( LQUERY ) THEN * * ==== Quick return in case of a workspace query ==== * CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, $ IHI, Z, LDZ, WORK, LWORK, INFO ) * ==== Ensure reported workspace size is backward-compatible with * . previous LAPACK versions. ==== WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) RETURN * ELSE * * ==== copy eigenvalues isolated by DGEBAL ==== * DO 10 I = 1, ILO - 1 WR( I ) = H( I, I ) WI( I ) = ZERO 10 CONTINUE DO 20 I = IHI + 1, N WR( I ) = H( I, I ) WI( I ) = ZERO 20 CONTINUE * * ==== Initialize Z, if requested ==== * IF( INITZ ) $ CALL DLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) * * ==== Quick return if possible ==== * IF( ILO.EQ.IHI ) THEN WR( ILO ) = H( ILO, ILO ) WI( ILO ) = ZERO RETURN END IF * * ==== DLAHQR/DLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'DHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, $ ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== DLAQR0 for big matrices; DLAHQR for small ones ==== * IF( N.GT.NMIN ) THEN CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, $ IHI, Z, LDZ, WORK, LWORK, INFO ) ELSE * * ==== Small matrix ==== * CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, $ IHI, Z, LDZ, INFO ) * IF( INFO.GT.0 ) THEN * * ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds * . when DLAHQR fails. ==== * KBOT = INFO * IF( N.GE.NL ) THEN * * ==== Larger matrices have enough subdiagonal scratch * . space to call DLAQR0 directly. ==== * CALL DLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR, $ WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) * ELSE * * ==== Tiny matrices don't have enough subdiagonal * . scratch space to benefit from DLAQR0. Hence, * . tiny matrices must be copied into a larger * . array before calling DLAQR0. ==== * CALL DLACPY( 'A', N, N, H, LDH, HL, NL ) HL( N+1, N ) = ZERO CALL DLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), $ NL ) CALL DLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR, $ WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO ) IF( WANTT .OR. INFO.NE.0 ) $ CALL DLACPY( 'A', N, N, HL, NL, H, LDH ) END IF END IF END IF * * ==== Clear out the trash, if necessary. ==== * IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) * * ==== Ensure reported workspace size is backward-compatible with * . previous LAPACK versions. ==== * WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) END IF * * ==== End of DHSEQR ==== * END SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, $ WORK, IWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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 DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, $ INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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 DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, $ Q2, INDX, INDXC, INDXP, COLTYP, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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 DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. 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 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 * * 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 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.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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 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.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. 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 * * 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 GIVPTR = 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.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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 DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. 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 thru 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 DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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 DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, $ LDGNUM, NL, NR, NRHS, SQRE DOUBLE PRECISION C, S * .. * .. Array Arguments .. INTEGER GIVCOL( LDGCOL, * ), PERM( * ) DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ), $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), $ POLES( LDGNUM, * ), WORK( * ), Z( * ) * .. * * Purpose * ======= * * DLALS0 applies back the multiplying factors of either the left or the * right singular vector matrix of a diagonal matrix appended by a row * to the right hand side matrix B in solving the least squares problem * using the divide-and-conquer SVD approach. * * For the left singular vector matrix, three types of orthogonal * matrices are involved: * * (1L) Givens rotations: the number of such rotations is GIVPTR; the * pairs of columns/rows they were applied to are stored in GIVCOL; * and the C- and S-values of these rotations are stored in GIVNUM. * * (2L) Permutation. The (NL+1)-st row of B is to be moved to the first * row, and for J=2:N, PERM(J)-th row of B is to be moved to the * J-th row. * * (3L) The left singular vector matrix of the remaining matrix. * * For the right singular vector matrix, four types of orthogonal * matrices are involved: * * (1R) The right singular vector matrix of the remaining matrix. * * (2R) If SQRE = 1, one extra Givens rotation to generate the right * null space. * * (3R) The inverse transformation of (2L). * * (4R) The inverse transformation of (1L). * * Arguments * ========= * * ICOMPQ (input) INTEGER * Specifies whether singular vectors are to be computed in * factored form: * = 0: Left singular vector matrix. * = 1: Right singular vector matrix. * * NL (input) INTEGER * The row dimension of the upper block. NL >= 1. * * NR (input) INTEGER * The row dimension of the lower block. NR >= 1. * * SQRE (input) INTEGER * = 0: the lower block is an NR-by-NR square matrix. * = 1: the lower block is an NR-by-(NR+1) rectangular matrix. * * The bidiagonal matrix has row dimension N = NL + NR + 1, * and column dimension M = N + SQRE. * * NRHS (input) INTEGER * The number of columns of B and BX. NRHS must be at least 1. * * B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS ) * On input, B contains the right hand sides of the least * squares problem in rows 1 through M. On output, B contains * the solution X in rows 1 through N. * * LDB (input) INTEGER * The leading dimension of B. LDB must be at least * max(1,MAX( M, N ) ). * * BX (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS ) * * LDBX (input) INTEGER * The leading dimension of BX. * * PERM (input) INTEGER array, dimension ( N ) * The permutations (from deflation and sorting) applied * to the two blocks. * * GIVPTR (input) INTEGER * The number of Givens rotations which took place in this * subproblem. * * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) * Each pair of numbers indicates a pair of rows/columns * involved in a Givens rotation. * * LDGCOL (input) INTEGER * The leading dimension of GIVCOL, must be at least N. * * GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) * Each number indicates the C or S value used in the * corresponding Givens rotation. * * LDGNUM (input) INTEGER * The leading dimension of arrays DIFR, POLES and * GIVNUM, must be at least K. * * POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) * On entry, POLES(1:K, 1) contains the new singular * values obtained from solving the secular equation, and * POLES(1:K, 2) is an array containing the poles in the secular * equation. * * DIFL (input) DOUBLE PRECISION array, dimension ( K ). * On entry, DIFL(I) is the distance between I-th updated * (undeflated) singular value and the I-th (undeflated) old * singular value. * * DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). * On entry, DIFR(I, 1) contains the distances between I-th * updated (undeflated) singular value and the I+1-th * (undeflated) old singular value. And DIFR(I, 2) is the * normalizing factor for the I-th right singular vector. * * Z (input) DOUBLE PRECISION array, dimension ( K ) * Contain the components of the deflation-adjusted updating row * vector. * * K (input) INTEGER * Contains the dimension of the non-deflated matrix, * This is the order of the related secular equation. 1 <= K <=N. * * C (input) DOUBLE PRECISION * C contains garbage if SQRE =0 and the C-value of a Givens * rotation related to the right null space if SQRE = 1. * * S (input) DOUBLE PRECISION * S contains garbage if SQRE =0 and the S-value of a Givens * rotation related to the right null space if SQRE = 1. * * WORK (workspace) DOUBLE PRECISION array, dimension ( K ) * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * Based on contributions by * Ming Gu and Ren-Cang Li, Computer Science Division, University of * California at Berkeley, USA * Osni Marques, LBNL/NERSC, USA * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO, NEGONE PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 ) * .. * .. Local Scalars .. INTEGER I, J, M, N, NLP1 DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DROT, DSCAL, $ XERBLA * .. * .. External Functions .. DOUBLE PRECISION DLAMC3, DNRM2 EXTERNAL DLAMC3, DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN INFO = -1 ELSE IF( NL.LT.1 ) THEN INFO = -2 ELSE IF( NR.LT.1 ) THEN INFO = -3 ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN INFO = -4 END IF * N = NL + NR + 1 * IF( NRHS.LT.1 ) THEN INFO = -5 ELSE IF( LDB.LT.N ) THEN INFO = -7 ELSE IF( LDBX.LT.N ) THEN INFO = -9 ELSE IF( GIVPTR.LT.0 ) THEN INFO = -11 ELSE IF( LDGCOL.LT.N ) THEN INFO = -13 ELSE IF( LDGNUM.LT.N ) THEN INFO = -15 ELSE IF( K.LT.1 ) THEN INFO = -20 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLALS0', -INFO ) RETURN END IF * M = N + SQRE NLP1 = NL + 1 * IF( ICOMPQ.EQ.0 ) THEN * * Apply back orthogonal transformations from the left. * * Step (1L): apply back the Givens rotations performed. * DO 10 I = 1, GIVPTR CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), $ GIVNUM( I, 1 ) ) 10 CONTINUE * * Step (2L): permute rows of B. * CALL DCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX ) DO 20 I = 2, N CALL DCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX ) 20 CONTINUE * * Step (3L): apply the inverse of the left singular vector * matrix to BX. * IF( K.EQ.1 ) THEN CALL DCOPY( NRHS, BX, LDBX, B, LDB ) IF( Z( 1 ).LT.ZERO ) THEN CALL DSCAL( NRHS, NEGONE, B, LDB ) END IF ELSE DO 50 J = 1, K DIFLJ = DIFL( J ) DJ = POLES( J, 1 ) DSIGJ = -POLES( J, 2 ) IF( J.LT.K ) THEN DIFRJ = -DIFR( J, 1 ) DSIGJP = -POLES( J+1, 2 ) END IF IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) ) $ THEN WORK( J ) = ZERO ELSE WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ / $ ( POLES( J, 2 )+DJ ) END IF DO 30 I = 1, J - 1 IF( ( Z( I ).EQ.ZERO ) .OR. $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN WORK( I ) = ZERO ELSE WORK( I ) = POLES( I, 2 )*Z( I ) / $ ( DLAMC3( POLES( I, 2 ), DSIGJ )- $ DIFLJ ) / ( POLES( I, 2 )+DJ ) END IF 30 CONTINUE DO 40 I = J + 1, K IF( ( Z( I ).EQ.ZERO ) .OR. $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN WORK( I ) = ZERO ELSE WORK( I ) = POLES( I, 2 )*Z( I ) / $ ( DLAMC3( POLES( I, 2 ), DSIGJP )+ $ DIFRJ ) / ( POLES( I, 2 )+DJ ) END IF 40 CONTINUE WORK( 1 ) = NEGONE TEMP = DNRM2( K, WORK, 1 ) CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO, $ B( J, 1 ), LDB ) CALL DLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ), $ LDB, INFO ) 50 CONTINUE END IF * * Move the deflated rows of BX to B also. * IF( K.LT.MAX( M, N ) ) $ CALL DLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX, $ B( K+1, 1 ), LDB ) ELSE * * Apply back the right orthogonal transformations. * * Step (1R): apply back the new right singular vector matrix * to B. * IF( K.EQ.1 ) THEN CALL DCOPY( NRHS, B, LDB, BX, LDBX ) ELSE DO 80 J = 1, K DSIGJ = POLES( J, 2 ) IF( Z( J ).EQ.ZERO ) THEN WORK( J ) = ZERO ELSE WORK( J ) = -Z( J ) / DIFL( J ) / $ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 ) END IF DO 60 I = 1, J - 1 IF( Z( J ).EQ.ZERO ) THEN WORK( I ) = ZERO ELSE WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1, $ 2 ) )-DIFR( I, 1 ) ) / $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 ) END IF 60 CONTINUE DO 70 I = J + 1, K IF( Z( J ).EQ.ZERO ) THEN WORK( I ) = ZERO ELSE WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I, $ 2 ) )-DIFL( I ) ) / $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 ) END IF 70 CONTINUE CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO, $ BX( J, 1 ), LDBX ) 80 CONTINUE END IF * * Step (2R): if SQRE = 1, apply back the rotation that is * related to the right null space of the subproblem. * IF( SQRE.EQ.1 ) THEN CALL DCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX ) CALL DROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S ) END IF IF( K.LT.MAX( M, N ) ) $ CALL DLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ), $ LDBX ) * * Step (3R): permute rows of B. * CALL DCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB ) IF( SQRE.EQ.1 ) THEN CALL DCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB ) END IF DO 90 I = 2, N CALL DCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB ) 90 CONTINUE * * Step (4R): apply back the Givens rotations performed. * DO 100 I = GIVPTR, 1, -1 CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), $ -GIVNUM( I, 1 ) ) 100 CONTINUE END IF * RETURN * * End of DLALS0 * END SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, $ LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, $ IWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, $ SMLSIZ * .. * .. Array Arguments .. INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), $ K( * ), PERM( LDGCOL, * ) DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ), $ DIFL( LDU, * ), DIFR( LDU, * ), $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), $ U( LDU, * ), VT( LDU, * ), WORK( * ), $ Z( LDU, * ) * .. * * Purpose * ======= * * DLALSA is an itermediate step in solving the least squares problem * by computing the SVD of the coefficient matrix in compact form (The * singular vectors are computed as products of simple orthorgonal * matrices.). * * If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector * matrix of an upper bidiagonal matrix to the right hand side; and if * ICOMPQ = 1, DLALSA applies the right singular vector matrix to the * right hand side. The singular vector matrices were generated in * compact form by DLALSA. * * Arguments * ========= * * * ICOMPQ (input) INTEGER * Specifies whether the left or the right singular vector * matrix is involved. * = 0: Left singular vector matrix * = 1: Right singular vector matrix * * SMLSIZ (input) INTEGER * The maximum size of the subproblems at the bottom of the * computation tree. * * N (input) INTEGER * The row and column dimensions of the upper bidiagonal matrix. * * NRHS (input) INTEGER * The number of columns of B and BX. NRHS must be at least 1. * * B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS ) * On input, B contains the right hand sides of the least * squares problem in rows 1 through M. * On output, B contains the solution X in rows 1 through N. * * LDB (input) INTEGER * The leading dimension of B in the calling subprogram. * LDB must be at least max(1,MAX( M, N ) ). * * BX (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS ) * On exit, the result of applying the left or right singular * vector matrix to B. * * LDBX (input) INTEGER * The leading dimension of BX. * * U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). * On entry, U contains the left singular vector matrices of all * subproblems at the bottom level. * * LDU (input) INTEGER, LDU = > N. * The leading dimension of arrays U, VT, DIFL, DIFR, * POLES, GIVNUM, and Z. * * VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). * On entry, VT' contains the right singular vector matrices of * all subproblems at the bottom level. * * K (input) INTEGER array, dimension ( N ). * * DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). * where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. * * DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). * On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record * distances between singular values on the I-th level and * singular values on the (I -1)-th level, and DIFR(*, 2 * I) * record the normalizing factors of the right singular vectors * matrices of subproblems on I-th level. * * Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). * On entry, Z(1, I) contains the components of the deflation- * adjusted updating row vector for subproblems on the I-th * level. * * POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). * On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old * singular values involved in the secular equations on the I-th * level. * * GIVPTR (input) INTEGER array, dimension ( N ). * On entry, GIVPTR( I ) records the number of Givens * rotations performed on the I-th problem on the computation * tree. * * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ). * On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the * locations of Givens rotations performed on the I-th level on * the computation tree. * * LDGCOL (input) INTEGER, LDGCOL = > N. * The leading dimension of arrays GIVCOL and PERM. * * PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ). * On entry, PERM(*, I) records permutations done on the I-th * level of the computation tree. * * GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). * On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- * values of Givens rotations performed on the I-th level on the * computation tree. * * C (input) DOUBLE PRECISION array, dimension ( N ). * On entry, if the I-th subproblem is not square, * C( I ) contains the C-value of a Givens rotation related to * the right null space of the I-th subproblem. * * S (input) DOUBLE PRECISION array, dimension ( N ). * On entry, if the I-th subproblem is not square, * S( I ) contains the S-value of a Givens rotation related to * the right null space of the I-th subproblem. * * WORK (workspace) DOUBLE PRECISION array. * The dimension must be at least N. * * IWORK (workspace) INTEGER array. * The dimension must be at least 3 * 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 * Ming Gu and Ren-Cang Li, Computer Science Division, University of * California at Berkeley, USA * Osni Marques, LBNL/NERSC, USA * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2, $ ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL, $ NR, NRF, NRP1, SQRE * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DLALS0, DLASDT, XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN INFO = -1 ELSE IF( SMLSIZ.LT.3 ) THEN INFO = -2 ELSE IF( N.LT.SMLSIZ ) THEN INFO = -3 ELSE IF( NRHS.LT.1 ) THEN INFO = -4 ELSE IF( LDB.LT.N ) THEN INFO = -6 ELSE IF( LDBX.LT.N ) THEN INFO = -8 ELSE IF( LDU.LT.N ) THEN INFO = -10 ELSE IF( LDGCOL.LT.N ) THEN INFO = -19 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLALSA', -INFO ) RETURN END IF * * Book-keeping and setting up the computation tree. * INODE = 1 NDIML = INODE + N NDIMR = NDIML + N * CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), $ IWORK( NDIMR ), SMLSIZ ) * * The following code applies back the left singular vector factors. * For applying back the right singular vector factors, go to 50. * IF( ICOMPQ.EQ.1 ) THEN GO TO 50 END IF * * The nodes on the bottom level of the tree were solved * by DLASDQ. The corresponding left and right singular vector * matrices are in explicit form. First apply back the left * singular vector matrices. * NDB1 = ( ND+1 ) / 2 DO 10 I = NDB1, ND * * IC : center row of each node * NL : number of rows of left subproblem * NR : number of rows of right subproblem * NLF: starting row of the left subproblem * NRF: starting row of the right subproblem * I1 = I - 1 IC = IWORK( INODE+I1 ) NL = IWORK( NDIML+I1 ) NR = IWORK( NDIMR+I1 ) NLF = IC - NL NRF = IC + 1 CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU, $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU, $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) 10 CONTINUE * * Next copy the rows of B that correspond to unchanged rows * in the bidiagonal matrix to BX. * DO 20 I = 1, ND IC = IWORK( INODE+I-1 ) CALL DCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX ) 20 CONTINUE * * Finally go through the left singular vector matrices of all * the other subproblems bottom-up on the tree. * J = 2**NLVL SQRE = 0 * DO 40 LVL = NLVL, 1, -1 LVL2 = 2*LVL - 1 * * find the first node LF and last node LL on * the current level LVL * IF( LVL.EQ.1 ) THEN LF = 1 LL = 1 ELSE LF = 2**( LVL-1 ) LL = 2*LF - 1 END IF DO 30 I = LF, LL IM1 = I - 1 IC = IWORK( INODE+IM1 ) NL = IWORK( NDIML+IM1 ) NR = IWORK( NDIMR+IM1 ) NLF = IC - NL NRF = IC + 1 J = J - 1 CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX, $ B( NLF, 1 ), LDB, PERM( NLF, LVL ), $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK, $ INFO ) 30 CONTINUE 40 CONTINUE GO TO 90 * * ICOMPQ = 1: applying back the right singular vector factors. * 50 CONTINUE * * First now go through the right singular vector matrices of all * the tree nodes top-down. * J = 0 DO 70 LVL = 1, NLVL LVL2 = 2*LVL - 1 * * Find the first node LF and last node LL on * the current level LVL. * IF( LVL.EQ.1 ) THEN LF = 1 LL = 1 ELSE LF = 2**( LVL-1 ) LL = 2*LF - 1 END IF DO 60 I = LL, LF, -1 IM1 = I - 1 IC = IWORK( INODE+IM1 ) NL = IWORK( NDIML+IM1 ) NR = IWORK( NDIMR+IM1 ) NLF = IC - NL NRF = IC + 1 IF( I.EQ.LL ) THEN SQRE = 0 ELSE SQRE = 1 END IF J = J + 1 CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB, $ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ), $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK, $ INFO ) 60 CONTINUE 70 CONTINUE * * The nodes on the bottom level of the tree were solved * by DLASDQ. The corresponding right singular vector * matrices are in explicit form. Apply them back. * NDB1 = ( ND+1 ) / 2 DO 80 I = NDB1, ND I1 = I - 1 IC = IWORK( INODE+I1 ) NL = IWORK( NDIML+I1 ) NR = IWORK( NDIMR+I1 ) NLP1 = NL + 1 IF( I.EQ.ND ) THEN NRP1 = NR ELSE NRP1 = NR + 1 END IF NLF = IC - NL NRF = IC + 1 CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU, $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU, $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) 80 CONTINUE * 90 CONTINUE * RETURN * * End of DLALSA * END SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, $ RANK, WORK, IWORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * ) * .. * * Purpose * ======= * * DLALSD uses the singular value decomposition of A to solve the least * squares problem of finding X to minimize the Euclidean norm of each * column of A*X-B, where A is N-by-N upper bidiagonal, and X and B * are N-by-NRHS. The solution X overwrites B. * * The singular values of A smaller than RCOND times the largest * singular value are treated as zero in solving the least squares * problem; in this case a minimum norm solution is returned. * The actual singular values are returned in D in ascending order. * * 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 XMP, Cray YMP, Cray C 90, or Cray 2. * It could conceivably fail on hexadecimal or decimal machines * without guard digits, but we know of none. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': D and E define an upper bidiagonal matrix. * = 'L': D and E define a lower bidiagonal matrix. * * SMLSIZ (input) INTEGER * The maximum size of the subproblems at the bottom of the * computation tree. * * N (input) INTEGER * The dimension of the bidiagonal matrix. N >= 0. * * NRHS (input) INTEGER * The number of columns of B. NRHS must be at least 1. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry D contains the main diagonal of the bidiagonal * matrix. On exit, if INFO = 0, D contains its singular values. * * E (input/output) DOUBLE PRECISION array, dimension (N-1) * Contains the super-diagonal entries of the bidiagonal matrix. * On exit, E has been destroyed. * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On input, B contains the right hand sides of the least * squares problem. On output, B contains the solution X. * * LDB (input) INTEGER * The leading dimension of B in the calling subprogram. * LDB must be at least max(1,N). * * RCOND (input) DOUBLE PRECISION * The singular values of A less than or equal to RCOND times * the largest singular value are treated as zero in solving * the least squares problem. If RCOND is negative, * machine precision is used instead. * For example, if diag(S)*X=B were the least squares problem, * where diag(S) is a diagonal matrix of singular values, the * solution would be X(i) = B(i) / S(i) if S(i) is greater than * RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to * RCOND*max(S). * * RANK (output) INTEGER * The number of singular values of A greater than RCOND times * the largest singular value. * * WORK (workspace) DOUBLE PRECISION array, dimension at least * (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), * where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). * * IWORK (workspace) INTEGER array, dimension at least * (3*N*NLVL + 11*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 singular value while * working on the submatrix lying in rows and columns * INFO/(N+1) through MOD(INFO,N+1). * * Further Details * =============== * * Based on contributions by * Ming Gu and Ren-Cang Li, Computer Science Division, University of * California at Berkeley, USA * Osni Marques, LBNL/NERSC, USA * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) * .. * .. Local Scalars .. INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM, $ GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL, $ NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI, $ SMLSZP, SQRE, ST, ST1, U, VT, Z DOUBLE PRECISION CS, EPS, ORGNRM, R, RCND, SN, TOL * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLANST EXTERNAL IDAMAX, DLAMCH, DLANST * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DLACPY, DLALSA, DLARTG, DLASCL, $ DLASDA, DLASDQ, DLASET, DLASRT, DROT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG, SIGN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( N.LT.0 ) THEN INFO = -3 ELSE IF( NRHS.LT.1 ) THEN INFO = -4 ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLALSD', -INFO ) RETURN END IF * EPS = DLAMCH( 'Epsilon' ) * * Set up the tolerance. * IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN RCND = EPS ELSE RCND = RCOND END IF * RANK = 0 * * Quick return if possible. * IF( N.EQ.0 ) THEN RETURN ELSE IF( N.EQ.1 ) THEN IF( D( 1 ).EQ.ZERO ) THEN CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB ) ELSE RANK = 1 CALL DLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO ) D( 1 ) = ABS( D( 1 ) ) END IF RETURN END IF * * Rotate the matrix if it is lower bidiagonal. * IF( UPLO.EQ.'L' ) THEN DO 10 I = 1, N - 1 CALL DLARTG( D( I ), E( I ), CS, SN, R ) D( I ) = R E( I ) = SN*D( I+1 ) D( I+1 ) = CS*D( I+1 ) IF( NRHS.EQ.1 ) THEN CALL DROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN ) ELSE WORK( I*2-1 ) = CS WORK( I*2 ) = SN END IF 10 CONTINUE IF( NRHS.GT.1 ) THEN DO 30 I = 1, NRHS DO 20 J = 1, N - 1 CS = WORK( J*2-1 ) SN = WORK( J*2 ) CALL DROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN ) 20 CONTINUE 30 CONTINUE END IF END IF * * Scale. * NM1 = N - 1 ORGNRM = DLANST( 'M', N, D, E ) IF( ORGNRM.EQ.ZERO ) THEN CALL DLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB ) RETURN END IF * CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO ) * * If N is smaller than the minimum divide size SMLSIZ, then solve * the problem with another solver. * IF( N.LE.SMLSIZ ) THEN NWORK = 1 + N*N CALL DLASET( 'A', N, N, ZERO, ONE, WORK, N ) CALL DLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B, $ LDB, WORK( NWORK ), INFO ) IF( INFO.NE.0 ) THEN RETURN END IF TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) ) DO 40 I = 1, N IF( D( I ).LE.TOL ) THEN CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) ELSE CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ), $ LDB, INFO ) RANK = RANK + 1 END IF 40 CONTINUE CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO, $ WORK( NWORK ), N ) CALL DLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB ) * * Unscale. * CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) CALL DLASRT( 'D', N, D, INFO ) CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO ) * RETURN END IF * * Book-keeping and setting up some constants. * NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1 * SMLSZP = SMLSIZ + 1 * U = 1 VT = 1 + SMLSIZ*N DIFL = VT + SMLSZP*N DIFR = DIFL + NLVL*N Z = DIFR + NLVL*N*2 C = Z + NLVL*N S = C + N POLES = S + N GIVNUM = POLES + 2*NLVL*N BX = GIVNUM + 2*NLVL*N NWORK = BX + N*NRHS * SIZEI = 1 + N K = SIZEI + N GIVPTR = K + N PERM = GIVPTR + N GIVCOL = PERM + NLVL*N IWK = GIVCOL + NLVL*N*2 * ST = 1 SQRE = 0 ICMPQ1 = 1 ICMPQ2 = 0 NSUB = 0 * DO 50 I = 1, N IF( ABS( D( I ) ).LT.EPS ) THEN D( I ) = SIGN( EPS, D( I ) ) END IF 50 CONTINUE * DO 60 I = 1, NM1 IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN NSUB = NSUB + 1 IWORK( NSUB ) = ST * * Subproblem found. First determine its size and then * apply divide and conquer on it. * IF( I.LT.NM1 ) THEN * * A subproblem with E(I) small for I < NM1. * NSIZE = I - ST + 1 IWORK( SIZEI+NSUB-1 ) = NSIZE ELSE IF( ABS( E( I ) ).GE.EPS ) THEN * * A subproblem with E(NM1) not too small but I = NM1. * NSIZE = N - ST + 1 IWORK( SIZEI+NSUB-1 ) = NSIZE ELSE * * A subproblem with E(NM1) small. This implies an * 1-by-1 subproblem at D(N), which is not solved * explicitly. * NSIZE = I - ST + 1 IWORK( SIZEI+NSUB-1 ) = NSIZE NSUB = NSUB + 1 IWORK( NSUB ) = N IWORK( SIZEI+NSUB-1 ) = 1 CALL DCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N ) END IF ST1 = ST - 1 IF( NSIZE.EQ.1 ) THEN * * This is a 1-by-1 subproblem and is not solved * explicitly. * CALL DCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N ) ELSE IF( NSIZE.LE.SMLSIZ ) THEN * * This is a small subproblem and is solved by DLASDQ. * CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE, $ WORK( VT+ST1 ), N ) CALL DLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ), $ E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ), $ N, B( ST, 1 ), LDB, WORK( NWORK ), INFO ) IF( INFO.NE.0 ) THEN RETURN END IF CALL DLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB, $ WORK( BX+ST1 ), N ) ELSE * * A large problem. Solve it using divide and conquer. * CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ), $ E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ), $ IWORK( K+ST1 ), WORK( DIFL+ST1 ), $ WORK( DIFR+ST1 ), WORK( Z+ST1 ), $ WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ), $ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ), $ WORK( GIVNUM+ST1 ), WORK( C+ST1 ), $ WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ), $ INFO ) IF( INFO.NE.0 ) THEN RETURN END IF BXST = BX + ST1 CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ), $ LDB, WORK( BXST ), N, WORK( U+ST1 ), N, $ WORK( VT+ST1 ), IWORK( K+ST1 ), $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ), $ WORK( Z+ST1 ), WORK( POLES+ST1 ), $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ), $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ), $ IWORK( IWK ), INFO ) IF( INFO.NE.0 ) THEN RETURN END IF END IF ST = I + 1 END IF 60 CONTINUE * * Apply the singular values and treat the tiny ones as zero. * TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) ) * DO 70 I = 1, N * * Some of the elements in D can be negative because 1-by-1 * subproblems were not solved explicitly. * IF( ABS( D( I ) ).LE.TOL ) THEN CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N ) ELSE RANK = RANK + 1 CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, $ WORK( BX+I-1 ), N, INFO ) END IF D( I ) = ABS( D( I ) ) 70 CONTINUE * * Now apply back the right singular vectors. * ICMPQ2 = 1 DO 80 I = 1, NSUB ST = IWORK( I ) ST1 = ST - 1 NSIZE = IWORK( SIZEI+I-1 ) BXST = BX + ST1 IF( NSIZE.EQ.1 ) THEN CALL DCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB ) ELSE IF( NSIZE.LE.SMLSIZ ) THEN CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, $ WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO, $ B( ST, 1 ), LDB ) ELSE CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N, $ B( ST, 1 ), LDB, WORK( U+ST1 ), N, $ WORK( VT+ST1 ), IWORK( K+ST1 ), $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ), $ WORK( Z+ST1 ), WORK( POLES+ST1 ), $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ), $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ), $ IWORK( IWK ), INFO ) IF( INFO.NE.0 ) THEN RETURN END IF END IF 80 CONTINUE * * Unscale and sort the singular values. * CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) CALL DLASRT( 'D', N, D, INFO ) CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO ) * RETURN * * End of DLALSD * END SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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 DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, L, LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * DLARZ 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. * * * H is a product of k elementary reflectors as returned by DTZRZF. * * 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. * * L (input) INTEGER * The number of entries of the vector V containing * the meaningful part of the Householder vectors. * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. * * V (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV)) * The vector v in the representation of H as returned by * DTZRZF. 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' * * Further Details * =============== * * Based on contributions by * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DGER * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C * IF( TAU.NE.ZERO ) THEN * * w( 1:n ) = C( 1, 1:n ) * CALL DCOPY( N, C, LDC, WORK, 1 ) * * w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) * CALL DGEMV( 'Transpose', L, N, ONE, C( M-L+1, 1 ), LDC, V, $ INCV, ONE, WORK, 1 ) * * C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) * CALL DAXPY( N, -TAU, WORK, 1, C, LDC ) * * C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... * tau * v( 1:l ) * w( 1:n )' * CALL DGER( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ), $ LDC ) END IF * ELSE * * Form C * H * IF( TAU.NE.ZERO ) THEN * * w( 1:m ) = C( 1:m, 1 ) * CALL DCOPY( M, C, 1, WORK, 1 ) * * w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) * CALL DGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC, $ V, INCV, ONE, WORK, 1 ) * * C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) * CALL DAXPY( M, -TAU, WORK, 1, C, 1 ) * * C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... * tau * w( 1:m ) * v( 1:l )' * CALL DGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ), $ LDC ) * END IF * END IF * RETURN * * End of DLARZ * END SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, $ LDV, T, LDT, C, LDC, WORK, LDWORK ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), $ WORK( LDWORK, * ) * .. * * Purpose * ======= * * DLARZB applies a real block reflector H or its transpose H**T to * a real distributed M-by-N C from the left or the right. * * Currently, only STOREV = 'R' and DIRECT = 'B' are supported. * * 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' (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, not supported yet) * = '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 (not supported yet) * = '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). * * L (input) INTEGER * The number of columns of the matrix V containing the * meaningful part of the Householder reflectors. * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. * * V (input) DOUBLE PRECISION array, dimension (LDV,NV). * If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. * * LDV (input) INTEGER * The leading dimension of the array V. * If STOREV = 'C', LDV >= L; 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. LDC >= 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). * * Further Details * =============== * * Based on contributions by * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER TRANST INTEGER I, INFO, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DTRMM, XERBLA * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * * Check for currently supported options * INFO = 0 IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN INFO = -3 ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLARZB', -INFO ) RETURN END IF * IF( LSAME( TRANS, 'N' ) ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C * * W( 1:n, 1:k ) = C( 1:k, 1:n )' * DO 10 J = 1, K CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 10 CONTINUE * * W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... * C( m-l+1:m, 1:n )' * V( 1:k, 1:l )' * IF( L.GT.0 ) $ CALL DGEMM( 'Transpose', 'Transpose', N, K, L, ONE, $ C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK, LDWORK ) * * W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T * CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T, $ LDT, WORK, LDWORK ) * * C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )' * DO 30 J = 1, N DO 20 I = 1, K C( I, J ) = C( I, J ) - WORK( J, I ) 20 CONTINUE 30 CONTINUE * * C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... * V( 1:k, 1:l )' * W( 1:n, 1:k )' * IF( L.GT.0 ) $ CALL DGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV, $ WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC ) * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' * * W( 1:m, 1:k ) = C( 1:m, 1:k ) * DO 40 J = 1, K CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... * C( 1:m, n-l+1:n ) * V( 1:k, 1:l )' * IF( L.GT.0 ) $ CALL DGEMM( 'No transpose', 'Transpose', M, K, L, ONE, $ C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK ) * * W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T' * CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T, $ LDT, WORK, LDWORK ) * * C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) * DO 60 J = 1, K DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE * * C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... * W( 1:m, 1:k ) * V( 1:k, 1:l ) * IF( L.GT.0 ) $ CALL DGEMM( 'No transpose', 'No transpose', M, L, K, -ONE, $ WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC ) * END IF * RETURN * * End of DLARZB * END SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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 * ======= * * DLARZT 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 * * Currently, only STOREV = 'R' and DIRECT = 'B' are supported. * * 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, not supported yet) * = '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 (not supported yet) * = '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 * =============== * * Based on contributions by * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA * * 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_____ * ( v1 v2 v3 ) / \ * ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 ) * V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 ) * ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 ) * ( v1 v2 v3 ) * . . . * . . . * 1 . . * 1 . * 1 * * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': * * ______V_____ * 1 / \ * . 1 ( 1 . . . . v1 v1 v1 v1 v1 ) * . . 1 ( . 1 . . . v2 v2 v2 v2 v2 ) * . . . ( . . 1 . . v3 v3 v3 v3 v3 ) * . . . * ( v1 v2 v3 ) * ( v1 v2 v3 ) * V = ( v1 v2 v3 ) * ( v1 v2 v3 ) * ( v1 v2 v3 ) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J * .. * .. External Subroutines .. EXTERNAL DGEMV, DTRMV, XERBLA * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Check for currently supported options * INFO = 0 IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLARZT', -INFO ) RETURN END IF * DO 20 I = K, 1, -1 IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO 10 J = I, K T( J, I ) = ZERO 10 CONTINUE ELSE * * general case * IF( I.LT.K ) THEN * * T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)' * CALL DGEMV( 'No transpose', K-I, N, -TAU( I ), $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, $ T( I+1, I ), 1 ) * * T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) * CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) END IF T( I, I ) = TAU( I ) END IF 20 CONTINUE RETURN * * End of DLARZT * END SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ) * .. * * Purpose * ======= * * DLASQ1 computes the singular values of a real N-by-N bidiagonal * matrix with diagonal D and off-diagonal E. The singular values * are computed to high relative accuracy, in the absence of * denormalization, underflow and overflow. The algorithm was first * presented in * * "Accurate singular values and differential qd algorithms" by K. V. * Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, * 1994, * * and the present implementation is described in "An implementation of * the dqds Algorithm (Positive Case)", LAPACK Working Note. * * Arguments * ========= * * N (input) INTEGER * The number of rows and columns in the matrix. N >= 0. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, D contains the diagonal elements of the * bidiagonal matrix whose SVD is desired. On normal exit, * D contains the singular values in decreasing order. * * E (input/output) DOUBLE PRECISION array, dimension (N) * On entry, elements E(1:N-1) contain the off-diagonal elements * of the bidiagonal matrix whose SVD is desired. * On exit, E is overwritten. * * WORK (workspace) DOUBLE PRECISION array, dimension (4*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 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) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * .. Local Scalars .. INTEGER I, IINFO DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX * .. * .. External Subroutines .. EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * INFO = 0 IF( N.LT.0 ) THEN INFO = -2 CALL XERBLA( 'DLASQ1', -INFO ) RETURN ELSE IF( N.EQ.0 ) THEN RETURN ELSE IF( N.EQ.1 ) THEN D( 1 ) = ABS( D( 1 ) ) RETURN ELSE IF( N.EQ.2 ) THEN CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX ) D( 1 ) = SIGMX D( 2 ) = SIGMN RETURN END IF * * Estimate the largest singular value. * SIGMX = ZERO DO 10 I = 1, N - 1 D( I ) = ABS( D( I ) ) SIGMX = MAX( SIGMX, ABS( E( I ) ) ) 10 CONTINUE D( N ) = ABS( D( N ) ) * * Early return if SIGMX is zero (matrix is already diagonal). * IF( SIGMX.EQ.ZERO ) THEN CALL DLASRT( 'D', N, D, IINFO ) RETURN END IF * DO 20 I = 1, N SIGMX = MAX( SIGMX, D( I ) ) 20 CONTINUE * * Copy D and E into WORK (in the Z format) and scale (squaring the * input data makes scaling by a power of the radix pointless). * EPS = DLAMCH( 'Precision' ) SAFMIN = DLAMCH( 'Safe minimum' ) SCALE = SQRT( EPS / SAFMIN ) CALL DCOPY( N, D, 1, WORK( 1 ), 2 ) CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 ) CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1, $ IINFO ) * * Compute the q's and e's. * DO 30 I = 1, 2*N - 1 WORK( I ) = WORK( I )**2 30 CONTINUE WORK( 2*N ) = ZERO * CALL DLASQ2( N, WORK, INFO ) * IF( INFO.EQ.0 ) THEN DO 40 I = 1, N D( I ) = SQRT( WORK( I ) ) 40 CONTINUE CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) END IF * RETURN * * End of DLASQ1 * END SUBROUTINE DLASQ2( N, Z, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * Modified to call DLAZQ3 in place of DLASQ3, 13 Feb 03, SJH. * * .. 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 DLAZQ3. * * Arguments * ========= * * N (input) INTEGER * The number of rows and columns in the matrix. N >= 0. * * Z (workspace) 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, $ N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE DOUBLE PRECISION D, DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, E, $ EMAX, EMIN, EPS, OLDEMN, QMAX, QMIN, S, SAFMIN, $ SIGMA, T, TAU, TEMP, TOL, TOL2, TRACE, ZMAX * .. * .. External Subroutines .. EXTERNAL DLAZQ3, 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 DLAZQ3 * TTYPE = 0 DMIN1 = ZERO DMIN2 = ZERO DN = ZERO DN1 = ZERO DN2 = ZERO TAU = ZERO * ITER = 2 NFAIL = 0 NDIV = 2*( N0-I0 ) * DO 140 IWHILA = 1, N + 1 IF( N0.LT.1 ) $ GO TO 150 * * 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 * * Store EMIN for passing to DLAZQ3. * Z( 4*N0-1 ) = EMIN * * 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 = 0 * NBIG = 30*( N0-I0+1 ) DO 120 IWHILB = 1, NBIG IF( I0.GT.N0 ) $ GO TO 130 * * While submatrix unfinished take a good dqds step. * CALL DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, $ DN2, 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 110 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 110 CONTINUE Z( 4*N0-1 ) = EMIN Z( 4*N0 ) = OLDEMN I0 = SPLT + 1 END IF END IF * 120 CONTINUE * INFO = 2 RETURN * * end IWHILB * 130 CONTINUE * 140 CONTINUE * INFO = 3 RETURN * * end IWHILA * 150 CONTINUE * * Move q's to the front. * DO 160 K = 2, N Z( K ) = Z( 4*K-3 ) 160 CONTINUE * * Sort and compute sum of eigenvalues. * CALL DLASRT( 'D', N, Z, IINFO ) * E = ZERO DO 170 K = N, 1, -1 E = E + Z( K ) 170 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 DLASRT( ID, N, D, INFO ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley 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 DLATRZ( M, N, L, A, LDA, TAU, WORK ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. INTEGER L, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix * [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means * of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal * matrix and, R and A1 are M-by-M upper triangular matrices. * * 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. * * L (input) INTEGER * The number of columns of the matrix A containing the * meaningful part of the Householder vectors. N-M >= L >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the leading M-by-N upper trapezoidal part of the * array A must contain the matrix to be factorized. * On exit, the leading M-by-M upper triangular part of A * contains the upper triangular matrix R, and elements N-L+1 to * N of the first M rows of A, with the array TAU, represent the * orthogonal matrix Z as a product of M elementary reflectors. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) DOUBLE PRECISION array, dimension (M) * The scalar factors of the elementary reflectors. * * WORK (workspace) DOUBLE PRECISION array, dimension (M) * * Further Details * =============== * * Based on contributions by * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA * * The factorization is obtained by Householder's method. The kth * transformation matrix, Z( k ), which is used to introduce zeros into * the ( m - k + 1 )th row of A, is given in the form * * Z( k ) = ( I 0 ), * ( 0 T( k ) ) * * where * * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), * ( 0 ) * ( z( k ) ) * * tau is a scalar and z( k ) is an l element vector. tau and z( k ) * are chosen to annihilate the elements of the kth row of A2. * * The scalar tau is returned in the kth element of TAU and the vector * u( k ) in the kth row of A2, such that the elements of z( k ) are * in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in * the upper triangular part of A1. * * Z is given by * * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I * .. * .. External Subroutines .. EXTERNAL DLARFG, DLARZ * .. * .. Executable Statements .. * * Test the input arguments * * Quick return if possible * IF( M.EQ.0 ) THEN RETURN ELSE IF( M.EQ.N ) THEN DO 10 I = 1, N TAU( I ) = ZERO 10 CONTINUE RETURN END IF * DO 20 I = M, 1, -1 * * Generate elementary reflector H(i) to annihilate * [ A(i,i) A(i,n-l+1:n) ] * CALL DLARFG( L+1, A( I, I ), A( I, N-L+1 ), LDA, TAU( I ) ) * * Apply H(i) to A(1:i-1,i:n) from the right * CALL DLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA, $ TAU( I ), A( 1, I ), LDA, WORK ) * 20 CONTINUE * RETURN * * End of DLATRZ * END SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * * -- LAPACK routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * This routine is deprecated and has been replaced by routine DORMRZ. * * DLATZM applies a Householder matrix generated by DTZRQF to a matrix. * * Let P = I - tau*u*u', u = ( 1 ), * ( v ) * where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if * SIDE = 'R'. * * If SIDE equals 'L', let * C = [ C1 ] 1 * [ C2 ] m-1 * n * Then C is overwritten by P*C. * * If SIDE equals 'R', let * C = [ C1, C2 ] m * 1 n-1 * Then C is overwritten by C*P. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form P * C * = 'R': form C * P * * 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' * (1 + (N-1)*abs(INCV)) if SIDE = 'R' * The vector v in the representation of P. 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 P. * * C1 (input/output) DOUBLE PRECISION array, dimension * (LDC,N) if SIDE = 'L' * (M,1) if SIDE = 'R' * On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 * if SIDE = 'R'. * * On exit, the first row of P*C if SIDE = 'L', or the first * column of C*P if SIDE = 'R'. * * C2 (input/output) DOUBLE PRECISION array, dimension * (LDC, N) if SIDE = 'L' * (LDC, N-1) if SIDE = 'R' * On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the * m x (n - 1) matrix C2 if SIDE = 'R'. * * On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P * if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the arrays C1 and C2. LDC >= (1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension * (N) if SIDE = 'L' * (M) if SIDE = 'R' * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DGER * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) ) $ RETURN * IF( LSAME( SIDE, 'L' ) ) THEN * * w := C1 + v' * C2 * CALL DCOPY( N, C1, LDC, WORK, 1 ) CALL DGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE, $ WORK, 1 ) * * [ C1 ] := [ C1 ] - tau* [ 1 ] * w' * [ C2 ] [ C2 ] [ v ] * CALL DAXPY( N, -TAU, WORK, 1, C1, LDC ) CALL DGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC ) * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * w := C1 + C2 * v * CALL DCOPY( M, C1, 1, WORK, 1 ) CALL DGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE, $ WORK, 1 ) * * [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] * CALL DAXPY( M, -TAU, WORK, 1, C1, 1 ) CALL DGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC ) END IF * RETURN * * End of DLATZM * END